*
* 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 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.
PERL_SET_THX(my_perl);
OP_REFCNT_INIT;
OP_CHECK_MUTEX_INIT;
+ KEYWORD_PLUGIN_MUTEX_INIT;
HINTS_REFCNT_INIT;
LOCALE_INIT;
+ USER_PROP_MUTEX_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
MUTEX_INIT(&PL_my_ctx_mutex);
# endif
JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
- init_i18nl10n(1);
+ init_uniprops();
#if defined(LOCAL_PATCH_COUNT)
PL_localpatches = local_patches; /* For possible -v */
* constructing hashes */
PL_hash_seed_set= TRUE;
}
- /* Note that strtab is a rather special HV. Assumptions are made
- about not iterating on it, and not adding tie magic to it.
- It is properly deallocated in perl_destruct() */
- PL_strtab = newHV();
- /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab,
- * which is not the case with PL_strtab itself */
- HvSHAREKEYS_off(PL_strtab); /* mandatory */
- hv_ksplit(PL_strtab, 1 << 11);
+ /* Allow PL_strtab to be pre-initialized before calling perl_construct.
+ * can use a custom optimized PL_strtab hash before calling perl_construct */
+ if (!PL_strtab) {
+ /* Note that strtab is a rather special HV. Assumptions are made
+ about not iterating on it, and not adding tie magic to it.
+ It is properly deallocated in perl_destruct() */
+ PL_strtab = newHV();
+
+ /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab,
+ * which is not the case with PL_strtab itself */
+ HvSHAREKEYS_off(PL_strtab); /* mandatory */
+ hv_ksplit(PL_strtab, 1 << 11);
+ }
Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
# endif
if ((long) PL_mmap_page_size < 0) {
- if (errno) {
- SV * const error = ERRSV;
- SvUPGRADE(error, SVt_PV);
- Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
- }
- else
- Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
+ Perl_croak(aTHX_ "panic: sysconf: %s",
+ errno ? Strerror(errno) : "pagesize unknown");
}
}
#elif defined(HAS_GETPAGESIZE)
/* 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);
}
/*
/*
=for apidoc perl_destruct
-Shuts down a Perl interpreter. See L<perlembed>.
+Shuts down a Perl interpreter. See L<perlembed> for a tutorial.
+
+C<my_perl> points to the Perl interpreter. It must have been previously
+created through the use of L</perl_alloc> and L</perl_construct>. It may
+have been initialised through L</perl_parse>, and may have been used
+through L</perl_run> and other means. This function should be called for
+any Perl interpreter that has been constructed with L</perl_construct>,
+even if subsequent operations on it failed, for example if L</perl_parse>
+returned a non-zero value.
+
+If the interpreter's C<PL_exit_flags> word has the
+C<PERL_EXIT_DESTRUCT_END> flag set, then this function will execute code
+in C<END> blocks before performing the rest of destruction. If it is
+desired to make any use of the interpreter between L</perl_parse> and
+L</perl_destruct> other than just calling L</perl_run>, then this flag
+should be set early on. This matters if L</perl_run> will not be called,
+or if anything else will be done in addition to calling L</perl_run>.
+
+Returns a value be a suitable value to pass to the C library function
+C<exit> (or to return from C<main>), to serve as an exit code indicating
+the nature of the way the interpreter terminated. This takes into account
+any failure of L</perl_parse> and any early exit from L</perl_run>.
+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
*/
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) {
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;
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
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;
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();
}
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;
}
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;
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);
- SvREFCNT_dec(PL_utf8_toupper);
- SvREFCNT_dec(PL_utf8_totitle);
- SvREFCNT_dec(PL_utf8_tolower);
- 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);
- 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;
- for (i = 0; i < POSIX_CC_COUNT; i++) {
- SvREFCNT_dec(PL_XPosix_ptrs[i]);
- PL_XPosix_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);
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
/*
=for apidoc perl_parse
-Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
+Tells a Perl interpreter to parse a Perl script. This performs most
+of the initialisation of a Perl interpreter. See L<perlembed> for
+a tutorial.
+
+C<my_perl> points to the Perl interpreter that is to parse the script.
+It must have been previously created through the use of L</perl_alloc>
+and L</perl_construct>. C<xsinit> 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<argc> and C<argv> supply a set of command-line arguments to the Perl
+interpreter, as would normally be passed to the C<main> function of
+a C program. C<argv[argc]> 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<C<$0>|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<env> 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<environ> 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<BEGIN>, C<UNITCHECK>, and C<CHECK> blocks. It does not execute
+C<INIT> 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</perl_run> 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</perl_destruct>
+and free it with L</perl_free>.
+
+For historical reasons, the non-zero return value also attempts to
+be a suitable value to pass to the C library function C<exit> (or to
+return from C<main>), 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<exit> 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<perl_run> being called (and therefore C<INIT> blocks and the
+main program running) despite a call to C<exit>. 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
*/
}
#endif
+ {
+ int i;
+ assert(argc >= 0);
+ for(i = 0; i != argc; i++)
+ assert(argv[i]);
+ assert(!argv[argc]);
+ }
PL_origargc = argc;
PL_origargv = argv;
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");
" 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"
# ifdef USE_SITECUSTOMIZE
" USE_SITECUSTOMIZE"
# endif
+# ifdef USE_THREAD_SAFE_LOCALE
+ " USE_THREAD_SAFE_LOCALE"
+# endif
;
PERL_UNUSED_ARG(cv);
PERL_UNUSED_VAR(items);
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());
/*
=for apidoc perl_run
-Tells a Perl interpreter to run. See L<perlembed>.
+Tells a Perl interpreter to run its main program. See L<perlembed>
+for a tutorial.
+
+C<my_perl> points to the Perl interpreter. It must have been previously
+created through the use of L</perl_alloc> and L</perl_construct>, and
+initialised through L</perl_parse>. This function should not be called
+if L</perl_parse> returned a non-zero value, indicating a failure in
+initialisation or compilation.
+
+This function executes code in C<INIT> blocks, and then executes the
+main program. The code to be executed is that established by the prior
+call to L</perl_parse>. If the interpreter's C<PL_exit_flags> word
+does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
+will also execute code in C<END> blocks. If it is desired to make any
+further use of the interpreter after calling this function, then C<END>
+blocks should be postponed to L</perl_destruct> 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<PERL_EXIT_DESTRUCT_END> 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</perl_destruct>
+and free it with L</perl_free>.
+
+For historical reasons, the non-zero return value also attempts to
+be a suitable value to pass to the C library function C<exit> (or to
+return from C<main>), 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</perl_destruct>.
=cut
*/
/*
=head1 SV Manipulation Functions
-=for apidoc p||get_sv
+=for apidoc get_sv
Returns the SV of the specified Perl scalar. C<flags> are passed to
C<gv_fetchpv>. If C<GV_ADD> is set and the
/*
=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<flags> are passed
/*
=head1 Hash Manipulation Functions
-=for apidoc p||get_hv
+=for apidoc get_hv
Returns the HV of the specified Perl hash. C<flags> are passed to
C<gv_fetchpv>. If C<GV_ADD> is set and the
/*
=head1 CV Manipulation Functions
-=for apidoc p||get_cvn_flags
+=for apidoc get_cvn_flags
Returns the CV of the specified Perl subroutine. C<flags> are passed to
C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
then NULL is returned.
-=for apidoc p||get_cv
+=for apidoc get_cv
Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_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<argv> (a C<NULL>-terminated array of strings) as arguments. See
}
/*
-=for apidoc p||call_pv
+=for apidoc call_pv
Performs a callback to the specified Perl sub. See L<perlcall>.
}
/*
-=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<perlcall>.
/* 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.
See L<perlcall>.
+=for apidoc Amnh||G_METHOD
+=for apidoc Amnh||G_METHOD_NAMED
+
=cut
*/
/* Eval a string. The G_EVAL flag is always assumed. */
/*
-=for apidoc p||eval_sv
+=for apidoc eval_sv
Tells Perl to C<eval> the string in the SV. It supports the same flags
as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>.
+The C<G_RETHROW> flag can be used if you only need eval_sv() to
+execute code specified by a string, but not catch any errors.
+
=cut
*/
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;
}
/*
-=for apidoc p||eval_pv
+=for apidoc eval_pv
Tells Perl to C<eval> the given string in scalar context and return an SV* result.
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;
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;
}
/*
=head1 Embedding Functions
-=for apidoc p||require_pv
+=for apidoc require_pv
Tells Perl to C<require> the file named by the string argument. It is
analogous to the Perl code C<eval "require '$file'">. It's even
}
}
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)++) ;
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2017, Larry Wall\n");
+ "\n\nCopyright 1987-2019, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
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");
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. */
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])
};
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);
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
/* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
(and not the architecture specific directories from $ENV{PERL5LIB}) */
+#include "perl_inc_macro.h"
/* Use the ~-expanded versions of APPLLIB (undocumented),
SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
*/
-#ifdef APPLLIB_EXP
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
- INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
-#endif
-
-#ifdef SITEARCH_EXP
- /* sitearch is always relative to sitelib on Windows for
- * DLL-based path intuition to work correctly */
-# if !defined(WIN32)
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
- INCPUSH_CAN_RELOCATE);
-# endif
-#endif
-
-#ifdef SITELIB_EXP
-# if defined(WIN32)
- /* this picks up sitearch as well */
- s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len);
- if (s)
- incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
-# else
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
-# endif
-#endif
+ INCPUSH_APPLLIB_EXP
+ INCPUSH_SITEARCH_EXP
+ INCPUSH_SITELIB_EXP
+ INCPUSH_PERL_VENDORARCH_EXP
+ INCPUSH_PERL_VENDORLIB_EXP
+ INCPUSH_ARCHLIB_EXP
+ INCPUSH_PRIVLIB_EXP
+ INCPUSH_PERL_OTHERLIBDIRS
+ INCPUSH_PERL5LIB
+ INCPUSH_APPLLIB_OLD_EXP
+ INCPUSH_SITELIB_STEM
+ INCPUSH_PERL_VENDORLIB_STEM
+ INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY
-#ifdef PERL_VENDORARCH_EXP
- /* vendorarch is always relative to vendorlib on Windows for
- * DLL-based path intuition to work correctly */
-# if !defined(WIN32)
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
- INCPUSH_CAN_RELOCATE);
-# endif
-#endif
-
-#ifdef PERL_VENDORLIB_EXP
-# if defined(WIN32)
- /* this picks up vendorarch as well */
- s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len);
- if (s)
- incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
-# else
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
- INCPUSH_CAN_RELOCATE);
-# endif
-#endif
-
-#ifdef ARCHLIB_EXP
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
-#endif
-
-#ifndef PRIVLIB_EXP
-# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
-#endif
-
-#if defined(WIN32)
- s = PerlEnv_lib_path(PERL_FS_VERSION, &len);
- if (s)
- incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
-#elif defined(NETWARE)
- S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
-#else
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
-#endif
-
-#ifdef PERL_OTHERLIBDIRS
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
- INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
- |INCPUSH_CAN_RELOCATE);
-#endif
-
- if (!TAINTING_get) {
-#ifndef VMS
-/*
- * It isn't possible to delete an environment variable with
- * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
- * case we treat PERL5LIB as undefined if it has a zero-length value.
- */
-#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
- if (perl5lib && *perl5lib != '\0')
-#else
- if (perl5lib)
-#endif
- incpush_use_sep(perl5lib, 0,
- INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
-#else /* VMS */
- /* Treat PERL5?LIB as a possible search list logical name -- the
- * "natural" VMS idiom for a Unix path string. We allow each
- * element to be a set of |-separated directories for compatibility.
- */
- char buf[256];
- int idx = 0;
- if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
- do {
- incpush_use_sep(buf, 0,
- INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
- } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
-#endif /* VMS */
- }
-
-/* Use the ~-expanded versions of APPLLIB (undocumented),
- SITELIB and VENDORLIB for older versions
-*/
-#ifdef APPLLIB_EXP
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
- |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
-#endif
-
-#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
- /* Search for version-specific dirs below here */
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
- INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
-#endif
-
-
-#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
- /* Search for version-specific dirs below here */
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
- INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
-#endif
-
-#ifdef PERL_OTHERLIBDIRS
- S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
- INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
- |INCPUSH_CAN_RELOCATE);
-#endif
#endif /* !PERL_IS_MINIPERL */
if (!TAINTING_get) {
}
}
+/*
+=for apidoc my_exit
+
+A wrapper for the C library L<exit(3)>, honoring what L<perlapi/PL_exit_flags>
+say to do.
+
+=cut
+*/
+
void
Perl_my_exit(pTHX_ U32 status)
{
#else
int exitstatus;
- if (errno & 255)
- STATUS_UNIX_SET(errno);
+ int eno = errno;
+ if (eno & 255)
+ STATUS_UNIX_SET(eno);
else {
exitstatus = STATUS_UNIX >> 8;
if (exitstatus & 255)
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
const char * const p = SvPVX_const(PL_e_script);
- const char *nl = strchr(p, '\n');
+ const char * const e = SvEND(PL_e_script);
+ const char *nl = (char *) memchr(p, '\n', e - p);
PERL_UNUSED_ARG(idx);
PERL_UNUSED_ARG(maxlen);
- nl = (nl) ? nl+1 : SvEND(PL_e_script);
+ nl = (nl) ? nl+1 : e;
if (nl-p == 0) {
filter_del(read_e_script);
return 0;