X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d333cbeb476c54aaf8f85ffdcfc187f23b4ea2ee..db9e73fd89ca2f9aade540ea03261f21bf885a8c:/perl.c diff --git a/perl.c b/perl.c index e6932b5..422a548 100644 --- a/perl.c +++ b/perl.c @@ -3,7 +3,7 @@ * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 - * 2013, 2014, 2015, 2016, 2017 by Larry Wall and others + * 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -95,6 +95,8 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) KEYWORD_PLUGIN_MUTEX_INIT; HINTS_REFCNT_INIT; LOCALE_INIT; + USER_PROP_MUTEX_INIT; + ENV_INIT; MUTEX_INIT(&PL_dollarzero_mutex); MUTEX_INIT(&PL_my_ctx_mutex); # endif @@ -215,26 +217,6 @@ Initializes a new Perl interpreter. See L. =cut */ -static void -S_fixup_platform_bugs(void) -{ -#if defined(__GLIBC__) && IVSIZE == 8 \ - && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) - { - IV l = 3; - IV r = -10; - /* Cannot do this check with inlined IV constants since - * that seems to work correctly even with the buggy glibc. */ - if (l % r == -3) { - dTHX; - /* Yikes, we have the bug. - * Patch in the workaround version. */ - PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix; - } - } -#endif -} - void perl_construct(pTHXx) { @@ -261,7 +243,10 @@ perl_construct(pTHXx) SvREADONLY_on(&PL_sv_placeholder); SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL; - PL_sighandlerp = (Sighandler_t) Perl_sighandler; + PL_sighandlerp = Perl_sighandler; + PL_sighandler1p = Perl_sighandler1; + PL_sighandler3p = Perl_sighandler3; + #ifdef PERL_USES_PL_PIDSTATUS PL_pidstatus = newHV(); #endif @@ -292,12 +277,13 @@ perl_construct(pTHXx) init_ids(); - S_fixup_platform_bugs(); - JMPENV_BOOTSTRAP; STATUS_ALL_SUCCESS; - init_i18nl10n(1); + init_uniprops(); + (void) uvchr_to_utf8_flags((U8 *) PL_TR_SPECIAL_HANDLING_UTF8, + TR_SPECIAL_HANDLING, + UNICODE_ALLOW_ABOVE_IV_MAX); #if defined(LOCAL_PATCH_COUNT) PL_localpatches = local_patches; /* For possible -v */ @@ -448,32 +434,12 @@ perl_construct(pTHXx) /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */ HvMAX(PL_registered_mros) = 0; - PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); - PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist); - PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist); - PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist); - PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist); - PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist); - PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist); - PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist); - PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist); - PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist); - PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist); - PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist); - PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist); - PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist); - PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist); - PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist); - PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist); - PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist); - PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist); - PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist); - PL_Assigned_invlist = _new_invlist_C_array(Assigned_invlist); -#ifdef HAS_POSIX_2008_LOCALE +#ifdef USE_POSIX_2008_LOCALE PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL); #endif ENTER; + init_i18nl10n(1); } /* @@ -593,7 +559,7 @@ Perl_dump_sv_child(pTHX_ SV *sv) #endif /* -=for apidoc Am|int|perl_destruct|PerlInterpreter *my_perl +=for apidoc perl_destruct Shuts down a Perl interpreter. See L for a tutorial. @@ -646,7 +612,6 @@ perl_destruct(pTHXx) PERL_WAIT_FOR_CHILDREN; destruct_level = PL_perl_destruct_level; -#if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL) { const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); if (s) { @@ -660,16 +625,13 @@ perl_destruct(pTHXx) else i = 0; } -#ifdef DEBUGGING if (destruct_level < i) destruct_level = i; -#endif #ifdef PERL_TRACK_MEMPOOL /* RT #114496, for perl_free */ PL_perl_destruct_level = i; #endif } } -#endif if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) { dJMPENV; @@ -687,6 +649,21 @@ perl_destruct(pTHXx) FREETMPS; assert(PL_scopestack_ix == 0); + /* normally when we get here, PL_parser should be null due to having + * its original (null) value restored by SAVEt_PARSER during leaving + * scope (usually before run-time starts in fact). + * But if a thread is created within a BEGIN block, the parser is + * duped, but the SAVEt_PARSER savestack entry isn't. So PL_parser + * never gets cleaned up. + * Clean it up here instead. This is a bit of a hack. + */ + if (PL_parser) { + /* stop parser_free() stomping on PL_curcop */ + PL_parser->saved_curcop = PL_curcop; + parser_free(PL_parser); + } + + /* Need to flush since END blocks can produce output */ /* flush stdout separately, since we can identify it */ #ifdef USE_PERLIO @@ -695,7 +672,7 @@ perl_destruct(pTHXx) if (*stdo && PerlIO_flush(stdo)) { PerlIO_restore_errno(stdo); if (errno) - PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s", + PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s\n", Strerror(errno)); if (!STATUS_UNIX) STATUS_ALL_FAILURE; @@ -742,7 +719,7 @@ perl_destruct(pTHXx) fail gracefully */ int fd[2]; - if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) { + if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) { perror("Debug leaking scalars socketpair failed"); abort(); } @@ -841,7 +818,7 @@ perl_destruct(pTHXx) back into Perl_debug_log, as if we never actually closed it */ if(got_fd != debug_fd) { - if (dup2(got_fd, debug_fd) == -1) { + if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) { where = "dup2"; goto abort; } @@ -1144,7 +1121,39 @@ perl_destruct(pTHXx) Safefree(PL_collation_name); PL_collation_name = NULL; #endif - +#if defined(USE_POSIX_2008_LOCALE) \ + && defined(USE_THREAD_SAFE_LOCALE) \ + && ! defined(HAS_QUERYLOCALE) + for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) { + Safefree(PL_curlocales[i]); + PL_curlocales[i] = NULL; + } +#endif +#ifdef HAS_POSIX_2008_LOCALE + { + /* This also makes sure we aren't using a locale object that gets freed + * below */ + const locale_t old_locale = uselocale(LC_GLOBAL_LOCALE); + if ( old_locale != LC_GLOBAL_LOCALE +# ifdef USE_POSIX_2008_LOCALE + && old_locale != PL_C_locale_obj +# endif + ) { + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s:%d: Freeing %p\n", __FILE__, __LINE__, old_locale)); + freelocale(old_locale); + } + } +# ifdef USE_LOCALE_NUMERIC + if (PL_underlying_numeric_obj) { + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s:%d: Freeing %p\n", __FILE__, __LINE__, + PL_underlying_numeric_obj)); + freelocale(PL_underlying_numeric_obj); + PL_underlying_numeric_obj = (locale_t) NULL; + } +# endif +#endif #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = NULL; @@ -1152,64 +1161,91 @@ perl_destruct(pTHXx) PL_numeric_radix_sv = NULL; #endif + if (PL_setlocale_buf) { + Safefree(PL_setlocale_buf); + PL_setlocale_buf = NULL; + } + if (PL_langinfo_buf) { Safefree(PL_langinfo_buf); PL_langinfo_buf = NULL; } - /* clear character classes */ - for (i = 0; i < POSIX_SWASH_COUNT; i++) { - SvREFCNT_dec(PL_utf8_swash_ptrs[i]); - PL_utf8_swash_ptrs[i] = NULL; - } - SvREFCNT_dec(PL_utf8_mark); +#ifdef USE_LOCALE_CTYPE + SvREFCNT_dec(PL_warn_locale); + PL_warn_locale = NULL; +#endif + + SvREFCNT_dec(PL_AboveLatin1); + PL_AboveLatin1 = NULL; + SvREFCNT_dec(PL_Assigned_invlist); + PL_Assigned_invlist = NULL; + SvREFCNT_dec(PL_GCB_invlist); + PL_GCB_invlist = NULL; + SvREFCNT_dec(PL_HasMultiCharFold); + PL_HasMultiCharFold = NULL; + SvREFCNT_dec(PL_InMultiCharFold); + PL_InMultiCharFold = NULL; + SvREFCNT_dec(PL_Latin1); + PL_Latin1 = NULL; + SvREFCNT_dec(PL_LB_invlist); + PL_LB_invlist = NULL; + SvREFCNT_dec(PL_SB_invlist); + PL_SB_invlist = NULL; + SvREFCNT_dec(PL_SCX_invlist); + PL_SCX_invlist = NULL; + SvREFCNT_dec(PL_UpperLatin1); + PL_UpperLatin1 = NULL; + SvREFCNT_dec(PL_in_some_fold); + PL_in_some_fold = NULL; + SvREFCNT_dec(PL_utf8_idcont); + PL_utf8_idcont = NULL; + SvREFCNT_dec(PL_utf8_idstart); + PL_utf8_idstart = NULL; + SvREFCNT_dec(PL_utf8_perl_idcont); + PL_utf8_perl_idcont = NULL; + SvREFCNT_dec(PL_utf8_perl_idstart); + PL_utf8_perl_idstart = NULL; + SvREFCNT_dec(PL_utf8_xidcont); + PL_utf8_xidcont = NULL; + SvREFCNT_dec(PL_utf8_xidstart); + PL_utf8_xidstart = NULL; + SvREFCNT_dec(PL_WB_invlist); + PL_WB_invlist = NULL; SvREFCNT_dec(PL_utf8_toupper); + PL_utf8_toupper = NULL; SvREFCNT_dec(PL_utf8_totitle); + PL_utf8_totitle = NULL; SvREFCNT_dec(PL_utf8_tolower); + PL_utf8_tolower = NULL; SvREFCNT_dec(PL_utf8_tofold); - SvREFCNT_dec(PL_utf8_idstart); - SvREFCNT_dec(PL_utf8_idcont); - SvREFCNT_dec(PL_utf8_foldable); - SvREFCNT_dec(PL_utf8_foldclosures); - SvREFCNT_dec(PL_AboveLatin1); + PL_utf8_tofold = NULL; + SvREFCNT_dec(PL_utf8_tosimplefold); + PL_utf8_tosimplefold = NULL; + SvREFCNT_dec(PL_utf8_charname_begin); + PL_utf8_charname_begin = NULL; + SvREFCNT_dec(PL_utf8_charname_continue); + PL_utf8_charname_continue = NULL; + SvREFCNT_dec(PL_utf8_mark); + PL_utf8_mark = NULL; SvREFCNT_dec(PL_InBitmap); - SvREFCNT_dec(PL_UpperLatin1); - SvREFCNT_dec(PL_Latin1); - SvREFCNT_dec(PL_NonL1NonFinalFold); - SvREFCNT_dec(PL_HasMultiCharFold); -#ifdef USE_LOCALE_CTYPE - SvREFCNT_dec(PL_warn_locale); -#endif - PL_utf8_mark = NULL; - PL_utf8_toupper = NULL; - PL_utf8_totitle = NULL; - PL_utf8_tolower = NULL; - PL_utf8_tofold = NULL; - PL_utf8_idstart = NULL; - PL_utf8_idcont = NULL; - PL_utf8_foldclosures = NULL; - PL_AboveLatin1 = NULL; - PL_InBitmap = NULL; - PL_HasMultiCharFold = NULL; -#ifdef USE_LOCALE_CTYPE - PL_warn_locale = NULL; -#endif - PL_Latin1 = NULL; - PL_NonL1NonFinalFold = NULL; - PL_UpperLatin1 = NULL; + PL_InBitmap = NULL; + SvREFCNT_dec(PL_CCC_non0_non230); + PL_CCC_non0_non230 = NULL; + SvREFCNT_dec(PL_Private_Use); + PL_Private_Use = NULL; + for (i = 0; i < POSIX_CC_COUNT; i++) { SvREFCNT_dec(PL_XPosix_ptrs[i]); PL_XPosix_ptrs[i] = NULL; + + if (i != _CC_CASED) { /* A copy of Alpha */ + SvREFCNT_dec(PL_Posix_ptrs[i]); + PL_Posix_ptrs[i] = NULL; + } } - PL_GCB_invlist = NULL; - PL_LB_invlist = NULL; - PL_SB_invlist = NULL; - PL_WB_invlist = NULL; - PL_Assigned_invlist = NULL; - if (!specialWARN(PL_compiling.cop_warnings)) - PerlMemShared_free(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = NULL; + free_and_set_cop_warnings(&PL_compiling, NULL); cophh_free(CopHINTHASH_get(&PL_compiling)); CopHINTHASH_set(&PL_compiling, cophh_new_empty()); CopFILE_free(&PL_compiling); @@ -1366,8 +1402,8 @@ perl_destruct(pTHXx) for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != (svtype)SVTYPEMASK) { PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" - " flags=0x%"UVxf - " refcnt=%"UVuf pTHX__FORMAT "\n" + " flags=0x%" UVxf + " refcnt=%" UVuf pTHX__FORMAT "\n" "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");" "serial %" UVuf "\n", (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt @@ -1594,7 +1630,7 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) } /* -=for apidoc Am|int|perl_parse|PerlInterpreter *my_perl|XSINIT_t xsinit|int argc|char **argv|char **env +=for apidoc perl_parse Tells a Perl interpreter to parse a Perl script. This performs most of the initialisation of a Perl interpreter. See L for @@ -1611,6 +1647,9 @@ interpreter, as would normally be passed to the C
function of a C program. C must be null. These arguments are where the script to parse is specified, either by naming a script file or by providing a script in a C<-e> option. +If L|perlvar/$0> will be written to in the Perl interpreter, then +the argument strings must be in writable memory, and so mustn't just be +string constants. C specifies a set of environment variables that will be used by this Perl interpreter. If non-null, it must point to a null-terminated @@ -1636,13 +1675,16 @@ For historical reasons, the non-zero return value also attempts to be a suitable value to pass to the C library function C (or to return from C
), to serve as an exit code indicating the nature of the way initialisation terminated. However, this isn't portable, -due to differing exit code conventions. An attempt is made to return -an exit code of the type required by the host operating system, but -because it is constrained to be non-zero, it is not necessarily possible -to indicate every type of exit. It is only reliable on Unix, where a -zero exit code can be augmented with a set bit that will be ignored. -In any case, this function is not the correct place to acquire an exit -code: one should get that from L. +due to differing exit code conventions. A historical bug is preserved +for the time being: if the Perl built-in C is called during this +function's execution, with a type of exit entailing a zero exit code +under the host operating system's conventions, then this function +returns zero rather than a non-zero value. This bug, [perl #2754], +leads to C being called (and therefore C blocks and the +main program running) despite a call to C. It has been preserved +because a popular module-installing module has come to rely on it and +needs time to be fixed. This issue is [perl #132577], and the original +bug is due to be fixed in Perl 5.30. =cut */ @@ -1851,7 +1893,15 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) call_list(oldscope, PL_checkav); } ret = STATUS_EXIT; - if (ret == 0) ret = 0x100; + if (ret == 0) { + /* + * At this point we should do + * ret = 0x100; + * to avoid [perl #2754], but that bugfix has been postponed + * because of the Module::Install breakage it causes + * [perl #132577]. + */ + } break; case 3: PerlIO_printf(Perl_error_log, "panic: top_env\n"); @@ -1967,7 +2017,7 @@ S_Internals_V(pTHX_ CV *cv) " PERL_USE_SAFE_PUTENV" # endif # ifdef SILENT_NO_TAINT_SUPPORT - " SILENT_NO_TAINT_SUPPORT" + " SILENT_NO_TAINT_SUPPORT" # endif # ifdef UNLINK_ALL_VERSIONS " UNLINK_ALL_VERSIONS" @@ -1993,6 +2043,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef USE_SITECUSTOMIZE " USE_SITECUSTOMIZE" # endif +# ifdef USE_THREAD_SAFE_LOCALE + " USE_THREAD_SAFE_LOCALE" +# endif ; PERL_UNUSED_ARG(cv); PERL_UNUSED_VAR(items); @@ -2228,10 +2281,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif (s = PerlEnv_getenv("PERL5OPT"))) { - /* s points to static memory in getenv(), which may be overwritten at - * any time; use a mortal copy instead */ - s = SvPVX(sv_2mortal(newSVpv(s, 0))); - while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') { @@ -2260,7 +2309,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) d = s; if (!*s) break; - if (!strchr("CDIMUdmtwW", *s)) + if (!memCHRs("CDIMUdmtwW", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -2301,7 +2350,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid, but avoids duplicating the logic from perl_construct(). */ - if (PL_tainting && + if (TAINT_get && PerlProc_getuid() == PerlProc_geteuid() && PerlProc_getgid() == PerlProc_getegid()) { Perl_drand48_init_r(&PL_internal_random_state, seed()); @@ -2561,7 +2610,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } /* -=for apidoc Am|int|perl_run|PerlInterpreter *my_perl +=for apidoc perl_run Tells a Perl interpreter to run its main program. See L for a tutorial. @@ -2610,7 +2659,7 @@ int perl_run(pTHXx) { I32 oldscope; - int ret = 0, exit_called = 0; + int ret = 0; dJMPENV; PERL_ARGS_ASSERT_PERL_RUN; @@ -2631,10 +2680,8 @@ perl_run(pTHXx) case 0: /* normal completion */ redo_body: run_body(oldscope); - goto handle_exit; + /* FALLTHROUGH */ case 2: /* my_exit() */ - exit_called = 1; - handle_exit: while (PL_scopestack_ix > oldscope) LEAVE; FREETMPS; @@ -2648,12 +2695,7 @@ perl_run(pTHXx) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - if (exit_called) { - ret = STATUS_EXIT; - if (ret == 0) ret = 0x100; - } else { - ret = 0; - } + ret = STATUS_EXIT; break; case 3: if (PL_restartop) { @@ -2723,7 +2765,7 @@ S_run_body(pTHX_ I32 oldscope) /* =head1 SV Manipulation Functions -=for apidoc p||get_sv +=for apidoc get_sv Returns the SV of the specified Perl scalar. C are passed to C. If C is set and the @@ -2749,7 +2791,7 @@ Perl_get_sv(pTHX_ const char *name, I32 flags) /* =head1 Array Manipulation Functions -=for apidoc p||get_av +=for apidoc get_av Returns the AV of the specified Perl global or package array with the given name (so it won't work on lexical variables). C are passed @@ -2779,7 +2821,7 @@ Perl_get_av(pTHX_ const char *name, I32 flags) /* =head1 Hash Manipulation Functions -=for apidoc p||get_hv +=for apidoc get_hv Returns the HV of the specified Perl hash. C are passed to C. If C is set and the @@ -2806,7 +2848,7 @@ Perl_get_hv(pTHX_ const char *name, I32 flags) /* =head1 CV Manipulation Functions -=for apidoc p||get_cvn_flags +=for apidoc get_cvn_flags Returns the CV of the specified Perl subroutine. C are passed to C. If C is set and the Perl subroutine does not @@ -2814,7 +2856,7 @@ exist then it will be declared (which has the same effect as saying C). If C is not set and the subroutine does not exist then NULL is returned. -=for apidoc p||get_cv +=for apidoc get_cv Uses C to get the length of C, then calls C. @@ -2858,7 +2900,7 @@ Perl_get_cv(pTHX_ const char *name, I32 flags) =head1 Callback Functions -=for apidoc p||call_argv +=for apidoc call_argv Performs a callback to the specified named and package-scoped Perl subroutine with C (a C-terminated array of strings) as arguments. See @@ -2889,7 +2931,7 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) } /* -=for apidoc p||call_pv +=for apidoc call_pv Performs a callback to the specified Perl sub. See L. @@ -2907,7 +2949,7 @@ Perl_call_pv(pTHX_ const char *sub_name, I32 flags) } /* -=for apidoc p||call_method +=for apidoc call_method Performs a callback to the specified Perl method. The blessed object must be on the stack. See L. @@ -2934,7 +2976,7 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* May be called with any of a CV, a GV, or an SV containing the name. */ /* -=for apidoc p||call_sv +=for apidoc call_sv Performs a callback to the Perl sub specified by the SV. @@ -2953,6 +2995,9 @@ not be depended on. See L. +=for apidoc Amnh||G_METHOD +=for apidoc Amnh||G_METHOD_NAMED + =cut */ @@ -3097,11 +3142,15 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) /* Eval a string. The G_EVAL flag is always assumed. */ /* -=for apidoc p||eval_sv +=for apidoc eval_sv Tells Perl to C the string in the SV. It supports the same flags as C, with the obvious exception of C. See L. +The C flag can be used if you only need eval_sv() to +execute code specified by a string, but not catch any errors. + +=for apidoc Amnh||G_RETHROW =cut */ @@ -3183,6 +3232,11 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) goto redo_body; } fail: + if (flags & G_RETHROW) { + JMPENV_POP; + croak_sv(ERRSV); + } + PL_stack_sp = PL_stack_base + oldmark; if ((flags & G_WANT) == G_ARRAY) retval = 0; @@ -3205,7 +3259,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) } /* -=for apidoc p||eval_pv +=for apidoc eval_pv Tells Perl to C the given string in scalar context and return an SV* result. @@ -3219,8 +3273,14 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) PERL_ARGS_ASSERT_EVAL_PV; - eval_sv(sv, G_SCALAR); - SvREFCNT_dec(sv); + if (croak_on_error) { + sv_2mortal(sv); + eval_sv(sv, G_SCALAR | G_RETHROW); + } + else { + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + } { dSP; @@ -3228,14 +3288,6 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) PUTBACK; } - /* just check empty string or undef? */ - if (croak_on_error) { - SV * const errsv = ERRSV; - if(SvTRUE_NN(errsv)) - /* replace with croak_sv? */ - Perl_croak_nocontext("%s", SvPV_nolen_const(errsv)); - } - return sv; } @@ -3244,7 +3296,7 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) /* =head1 Embedding Functions -=for apidoc p||require_pv +=for apidoc require_pv Tells Perl to C the file named by the string argument. It is analogous to the Perl code C. It's even @@ -3354,6 +3406,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " B dump suBroutine definitions, including special Blocks like BEGIN\n", " L trace some locale setting information--for Perl core development\n", " i trace PerlIO layer processing\n", + " y trace y///, tr/// compilation and execution\n", NULL }; UV uv = 0; @@ -3362,7 +3415,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy"; for (; isWORDCHAR(**s); (*s)++) { const char * const d = strchr(debopts,**s); @@ -3374,7 +3427,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) } } else if (isDIGIT(**s)) { - const char* e; + const char* e = *s + strlen(*s); if (grok_atoUV(*s, &uv, &e)) *s = e; for (; isWORDCHAR(**s); (*s)++) ; @@ -3685,16 +3738,12 @@ Perl_moreswitches(pTHX_ const char *s) return s; case 'W': PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; - if (!specialWARN(PL_compiling.cop_warnings)) - PerlMemShared_free(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = pWARN_ALL ; + free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); s++; return s; case 'X': PL_dowarn = G_WARN_ALL_OFF; - if (!specialWARN(PL_compiling.cop_warnings)) - PerlMemShared_free(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = pWARN_NONE ; + free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); s++; return s; case '*': @@ -3783,7 +3832,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2017, Larry Wall\n"); + "\n\nCopyright 1987-2020, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3810,12 +3859,6 @@ S_minus_v(pTHX) PerlIO_printf(PIO_stdout, "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif -#ifdef UNDER_CE - PerlIO_printf(PIO_stdout, - "WINCE port by Rainer Keuchel, 2001-2002\n" - "Built on " __DATE__ " " __TIME__ "\n\n"); - wce_hitreturn(); -#endif #ifdef __SYMBIAN32__ PerlIO_printf(PIO_stdout, "Symbian port by Nokia, 2004-2005\n"); @@ -3969,6 +4012,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) UV uv; /* if find_script() returns, it returns a malloc()-ed value */ scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); + s = scriptname + strlen(scriptname); if (strBEGINs(scriptname, "/dev/fd/") && isDIGIT(scriptname[8]) @@ -4032,7 +4076,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) }; const char * const err = "Failed to create a fake bit bucket"; if (strEQ(scriptname, BIT_BUCKET)) { - int tmpfd = Perl_my_mkstemp(tmpname); + int tmpfd = Perl_my_mkstemp_cloexec(tmpname); if (tmpfd > -1) { scriptname = tmpname; close(tmpfd); @@ -4059,8 +4103,6 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) CopFILE(PL_curcop), Strerror(errno)); } fd = PerlIO_fileno(rsfp); - if (fd >= 0) - setfd_cloexec(fd); if (fd < 0 || (PerlLIO_fstat(fd, &tmpstatbuf) >= 0 @@ -5132,6 +5174,15 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) } } +/* +=for apidoc my_exit + +A wrapper for the C library L, honoring what L +say to do. + +=cut +*/ + void Perl_my_exit(pTHX_ U32 status) { @@ -5192,7 +5243,7 @@ Perl_my_failure_exit(pTHX) * success/warning codes to fatal with out changing * the POSIX status code. The severity makes VMS native * status handling work, while UNIX mode programs use the - * the POSIX exit codes. + * POSIX exit codes. */ if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { STATUS_NATIVE &= STS$M_COND_ID;