X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7d00a3405ca1345227668bfc2bac750590adf68f..577d3e04be845580196418dd9df1575e2cb4c0b6:/perl.c diff --git a/perl.c b/perl.c index 25b4a26..96ad0f6 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 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. @@ -297,6 +297,29 @@ perl_construct(pTHXx) JMPENV_BOOTSTRAP; STATUS_ALL_SUCCESS; + 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); + PL_SCX_invlist = _new_invlist_C_array(_Perl_SCX_invlist); + init_i18nl10n(1); #if defined(LOCAL_PATCH_COUNT) @@ -448,27 +471,6 @@ 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 PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL); #endif @@ -593,9 +595,33 @@ Perl_dump_sv_child(pTHX_ SV *sv) #endif /* -=for apidoc perl_destruct - -Shuts down a Perl interpreter. See L. +=for apidoc Am|int|perl_destruct|PerlInterpreter *my_perl + +Shuts down a Perl interpreter. See L for a tutorial. + +C points to the Perl interpreter. It must have been previously +created through the use of L and L. It may +have been initialised through L, and may have been used +through L and other means. This function should be called for +any Perl interpreter that has been constructed with L, +even if subsequent operations on it failed, for example if L +returned a non-zero value. + +If the interpreter's C word has the +C flag set, then this function will execute code +in C blocks before performing the rest of destruction. If it is +desired to make any use of the interpreter between L and +L other than just calling L, then this flag +should be set early on. This matters if L will not be called, +or if anything else will be done in addition to calling L. + +Returns a value 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 the interpreter terminated. This takes into account +any failure of L and any early exit from L. +The exit code is of the type required by the host operating system, +so because of differing exit code conventions it is not portable to +interpret specific numeric values as having specific meanings. =cut */ @@ -671,7 +697,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; @@ -718,7 +744,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(); } @@ -817,7 +843,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; } @@ -1133,6 +1159,19 @@ perl_destruct(pTHXx) PL_langinfo_buf = NULL; } +#ifdef USE_POSIX_2008_LOCALE +# ifdef USE_LOCALE_NUMERIC + + if (PL_underlying_numeric_obj) { + /* Make sure we aren't using the locale space we are about to free */ + uselocale(LC_GLOBAL_LOCALE); + freelocale(PL_underlying_numeric_obj); + PL_underlying_numeric_obj = (locale_t) NULL; + } + +# endif +#endif + /* clear character classes */ for (i = 0; i < POSIX_SWASH_COUNT; i++) { SvREFCNT_dec(PL_utf8_swash_ptrs[i]); @@ -1180,6 +1219,7 @@ perl_destruct(pTHXx) PL_GCB_invlist = NULL; PL_LB_invlist = NULL; PL_SB_invlist = NULL; + PL_SCX_invlist = NULL; PL_WB_invlist = NULL; PL_Assigned_invlist = NULL; @@ -1570,9 +1610,61 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) } /* -=for apidoc perl_parse - -Tells a Perl interpreter to parse a Perl script. See L. +=for apidoc Am|int|perl_parse|PerlInterpreter *my_perl|XSINIT_t xsinit|int argc|char **argv|char **env + +Tells a Perl interpreter to parse a Perl script. This performs most +of the initialisation of a Perl interpreter. See L for +a tutorial. + +C points to the Perl interpreter that is to parse the script. +It must have been previously created through the use of L +and L. C points to a callback function that +will be called to set up the ability for this Perl interpreter to load +XS extensions, or may be null to perform no such setup. + +C and C supply a set of command-line arguments to the Perl +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 +array of environment strings. If null, the Perl interpreter will use +the environment supplied by the C global variable. + +This function initialises the interpreter, and parses and compiles the +script specified by the command-line arguments. This includes executing +code in C, C, and C blocks. It does not execute +C blocks or the main program. + +Returns an integer of slightly tricky interpretation. The correct +use of the return value is as a truth value indicating whether there +was a failure in initialisation. If zero is returned, this indicates +that initialisation was successful, and it is safe to proceed to call +L and make other use of it. If a non-zero value is returned, +this indicates some problem that means the interpreter wants to terminate. +The interpreter should not be just abandoned upon such failure; the caller +should proceed to shut the interpreter down cleanly with L +and free it with L. + +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. 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 */ @@ -1623,6 +1715,13 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) } #endif + { + int i; + assert(argc >= 0); + for(i = 0; i != argc; i++) + assert(argv[i]); + assert(!argv[argc]); + } PL_origargc = argc; PL_origargv = argv; @@ -1774,6 +1873,15 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) call_list(oldscope, PL_checkav); } ret = STATUS_EXIT; + 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"); @@ -2483,9 +2591,47 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } /* -=for apidoc perl_run - -Tells a Perl interpreter to run. See L. +=for apidoc Am|int|perl_run|PerlInterpreter *my_perl + +Tells a Perl interpreter to run its main program. See L +for a tutorial. + +C points to the Perl interpreter. It must have been previously +created through the use of L and L, and +initialised through L. This function should not be called +if L returned a non-zero value, indicating a failure in +initialisation or compilation. + +This function executes code in C blocks, and then executes the +main program. The code to be executed is that established by the prior +call to L. If the interpreter's C word +does not have the C flag set, then this function +will also execute code in C blocks. If it is desired to make any +further use of the interpreter after calling this function, then C +blocks should be postponed to L time by setting that flag. + +Returns an integer of slightly tricky interpretation. The correct use +of the return value is as a truth value indicating whether the program +terminated non-locally. If zero is returned, this indicates that +the program ran to completion, and it is safe to make other use of the +interpreter (provided that the C flag was set as +described above). If a non-zero value is returned, this indicates that +the interpreter wants to terminate early. The interpreter should not be +just abandoned because of this desire to terminate; the caller should +proceed to shut the interpreter down cleanly with L +and free it with L. + +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 the program 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. =cut */ @@ -2494,7 +2640,7 @@ int perl_run(pTHXx) { I32 oldscope; - int ret = 0; + int ret = 0, exit_called = 0; dJMPENV; PERL_ARGS_ASSERT_PERL_RUN; @@ -2515,8 +2661,10 @@ perl_run(pTHXx) case 0: /* normal completion */ redo_body: run_body(oldscope); - /* FALLTHROUGH */ + goto handle_exit; case 2: /* my_exit() */ + exit_called = 1; + handle_exit: while (PL_scopestack_ix > oldscope) LEAVE; FREETMPS; @@ -2530,7 +2678,12 @@ perl_run(pTHXx) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - ret = STATUS_EXIT; + if (exit_called) { + ret = STATUS_EXIT; + if (ret == 0) ret = 0x100; + } else { + ret = 0; + } break; case 3: if (PL_restartop) { @@ -3660,7 +3813,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2017, Larry Wall\n"); + "\n\nCopyright 1987-2018, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3783,8 +3936,9 @@ STATIC void S_init_main_stash(pTHX) { GV *gv; + HV *hv = newHV(); - PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV()); + PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv); /* We know that the string "main" will be in the global shared string table, so it's a small saving to use it rather than allocate another 8 bytes. */ @@ -3908,16 +4062,12 @@ 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)) { -#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */ - int old_umask = umask(0177); - int tmpfd = mkstemp(tmpname); - umask(old_umask); + int tmpfd = Perl_my_mkstemp_cloexec(tmpname); if (tmpfd > -1) { scriptname = tmpname; close(tmpfd); } else Perl_croak(aTHX_ err); -#endif } #endif rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); @@ -3939,15 +4089,6 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) CopFILE(PL_curcop), Strerror(errno)); } fd = PerlIO_fileno(rsfp); -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - if (fd >= 0) { - /* ensure close-on-exec */ - if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { - Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); - } - } -#endif if (fd < 0 || (PerlLIO_fstat(fd, &tmpstatbuf) >= 0