diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CORE/inline.h')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/CORE/inline.h | 243 |
1 files changed, 158 insertions, 85 deletions
diff --git a/Master/tlpkg/tlperl/lib/CORE/inline.h b/Master/tlpkg/tlperl/lib/CORE/inline.h index 0fe8a0eee1a..46a8cb6d342 100755 --- a/Master/tlpkg/tlperl/lib/CORE/inline.h +++ b/Master/tlpkg/tlperl/lib/CORE/inline.h @@ -25,6 +25,14 @@ S_av_top_index(pTHX_ AV *av) /* ------------------------------- cv.h ------------------------------- */ +PERL_STATIC_INLINE GV * +S_CvGV(pTHX_ CV *sv) +{ + return CvNAMED(sv) + ? Perl_cvgv_from_hek(aTHX_ sv) + : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; +} + PERL_STATIC_INLINE I32 * S_CvDEPTHp(const CV * const sv) { @@ -82,6 +90,41 @@ S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len) } #endif +/* ------------------------------- pad.h ------------------------------ */ + +#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C) +PERL_STATIC_INLINE bool +PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq) +{ + /* 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 */ + + 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; + } + else if ( + (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)) + ) + return TRUE; + return FALSE; +} +#endif + /* ----------------------------- regexp.h ----------------------------- */ PERL_STATIC_INLINE struct regexp * @@ -148,27 +191,15 @@ SvAMAGIC_off(SV *sv) } PERL_STATIC_INLINE U32 -S_SvPADTMP_on(SV *sv) -{ - assert(!(SvFLAGS(sv) & SVs_PADMY)); - return SvFLAGS(sv) |= SVs_PADTMP; -} -PERL_STATIC_INLINE U32 -S_SvPADTMP_off(SV *sv) -{ - assert(!(SvFLAGS(sv) & SVs_PADMY)); - return SvFLAGS(sv) &= ~SVs_PADTMP; -} -PERL_STATIC_INLINE U32 S_SvPADSTALE_on(SV *sv) { - assert(SvFLAGS(sv) & SVs_PADMY); + assert(!(SvFLAGS(sv) & SVs_PADTMP)); return SvFLAGS(sv) |= SVs_PADSTALE; } PERL_STATIC_INLINE U32 S_SvPADSTALE_off(SV *sv) { - assert(SvFLAGS(sv) & SVs_PADMY); + assert(!(SvFLAGS(sv) & SVs_PADTMP)); return SvFLAGS(sv) &= ~SVs_PADSTALE; } #if defined(PERL_CORE) || defined (PERL_EXT) @@ -188,64 +219,16 @@ S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) /* ------------------------------- 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" +#ifdef GCC_DIAG_PRAGMA +GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */ #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); -} +#ifdef GCC_DIAG_PRAGMA +GCC_DIAG_RESTORE /* Intentionally left semicolonless. */ #endif /* ------------------------------- utf8.h ------------------------------- */ @@ -266,28 +249,41 @@ S_append_utf8_from_native_byte(const U8 byte, U8** dest) } } -/* 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) -{ - PERL_ARGS_ASSERT_ISIDFIRST_LAZY; +A helper function for the macro isUTF8_CHAR(), which should be used instead of +this function. The macro will handle smaller code points directly saving time, +using this function as a fall-back for higher code points. - return isIDFIRST_lazy_if(p,1); -} +Tests if the first bytes of string C<s> form a valid UTF-8 character. 0 is +returned if the bytes starting at C<s> up to but not including C<e> do not form a +complete well-formed UTF-8 character; otherwise the number of bytes in the +character is returned. -PERL_STATIC_INLINE bool -S_isALNUM_lazy(pTHX_ const char* p) +Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a valid UTF-8 +character. + +=cut */ +PERL_STATIC_INLINE STRLEN +S__is_utf8_char_slow(const U8 *s, const U8 *e) { - PERL_ARGS_ASSERT_ISALNUM_LAZY; + dTHX; /* The function called below requires thread context */ + + STRLEN actual_len; + + PERL_ARGS_ASSERT__IS_UTF8_CHAR_SLOW; - return isALNUM_lazy_if(p,1); + assert(e >= s); + utf8n_to_uvchr(s, e - s, &actual_len, UTF8_CHECK_ONLY); + + return (actual_len == (STRLEN) -1) ? 0 : actual_len; } /* ------------------------------- perl.h ----------------------------- */ /* +=head1 Miscellaneous Functions + =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. @@ -308,7 +304,7 @@ S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char PERL_ARGS_ASSERT_IS_SAFE_SYSCALL; - if (pv && len > 1) { + if (len > 1) { char *null_at; if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) { SETERRNO(ENOENT, LIB_INVARG); @@ -323,11 +319,88 @@ S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * + +Return true if the supplied filename has a newline character +immediately before the final NUL. + +My original look at this incorrectly used the len from SvPV(), but +that's incorrect, since we allow for a NUL in pv[len-1]. + +So instead, strlen() and work from there. + +This allow for the user reading a filename, forgetting to chomp it, +then calling: + + open my $foo, "$file\0"; + +*/ + +#ifdef PERL_CORE + +PERL_STATIC_INLINE bool +S_should_warn_nl(const char *pv) { + STRLEN len; + + PERL_ARGS_ASSERT_SHOULD_WARN_NL; + + len = strlen(pv); + + return len > 0 && pv[len-1] == '\n'; +} + +#endif + +/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */ + +#define MAX_CHARSET_NAME_LENGTH 2 + +PERL_STATIC_INLINE const char * +get_regex_charset_name(const U32 flags, STRLEN* const lenp) +{ + /* 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 */ + + *lenp = 1; + switch (get_regex_charset(flags)) { + 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; + } + /* The NOT_REACHED; hides an assert() which has a rather complex + * definition in perl.h. */ + NOT_REACHED; /* NOTREACHED */ + return "?"; /* Unknown */ +} + +/* + +Return false if any get magic is on the SV other than taint magic. + +*/ + +PERL_STATIC_INLINE bool +S_sv_only_taint_gmagic(SV *sv) { + MAGIC *mg = SvMAGIC(sv); + + PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC; + + while (mg) { + if (mg->mg_type != PERL_MAGIC_taint + && !(mg->mg_flags & MGf_GSKIP) + && mg->mg_virtual->svt_get) { + return FALSE; + } + mg = mg->mg_moremagic; + } + + return TRUE; +} + +/* * ex: set ts=8 sts=4 sw=4 et: */ |