*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
* 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
- * by Larry Wall and others
+ * 2013, 2014, 2015, 2016, 2017 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.
* and destroy a perl interpreter, plus the functions used by XS code to
* call back into perl. Note that it does not contain the actual main()
* function of the interpreter; that can be found in perlmain.c
+ *
+ * Note that at build time this file is also linked to as perlmini.c,
+ * and perlmini.o is then built with PERL_IS_MINIPERL defined, which is
+ * then used to create the miniperl executable, rather than perl.o.
*/
#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
# endif
#endif
-#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
-char *getenv (char *); /* Usually in <stdlib.h> */
-#endif
-
static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
PERL_SET_THX(my_perl);
OP_REFCNT_INIT;
OP_CHECK_MUTEX_INIT;
+ KEYWORD_PLUGIN_MUTEX_INIT;
HINTS_REFCNT_INIT;
+ LOCALE_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
MUTEX_INIT(&PL_my_ctx_mutex);
# endif
=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)
{
init_stacks();
+/* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls
+ * things that may put SVs on the stack.
+ */
+
+#ifdef NO_PERL_INTERNAL_RAND_SEED
+ Perl_drand48_init_r(&PL_internal_random_state, seed());
+#else
+ {
+ UV seed;
+ const char *env_pv;
+ if (PerlProc_getuid() != PerlProc_geteuid() ||
+ PerlProc_getgid() != PerlProc_getegid() ||
+ !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) ||
+ grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) {
+ seed = seed();
+ }
+ Perl_drand48_init_r(&PL_internal_random_state, (U32)seed);
+ }
+#endif
+
init_ids();
+ S_fixup_platform_bugs();
+
JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
PL_localpatches = local_patches; /* For possible -v */
#endif
+#if defined(LIBM_LIB_VERSION)
+ /*
+ * Some BSDs and Cygwin default to POSIX math instead of IEEE.
+ * This switches them over to IEEE.
+ */
+ _LIB_VERSION = _IEEE_;
+#endif
+
#ifdef HAVE_INTERP_INTERN
sys_intern_init();
#endif
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvs("");
- sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
- sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
- sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
+ SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */
+ SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */
+ SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */
#ifdef USE_ITHREADS
/* First entry is a list of empty elements. It needs to be initialised
else all hell breaks loose in S_find_uninit_var(). */
#ifdef USE_REENTRANT_API
Perl_reentrant_init(aTHX);
#endif
-#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
- /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
- * This MUST be done before any hash stores or fetches take place.
- * If you set PL_hash_seed (and presumably also PL_hash_seed_set)
- * yourself, it is your responsibility to provide a good random seed!
- * You can also define PERL_HASH_SEED in compile time, see hv.h.
- *
- * XXX: fix this comment */
if (PL_hash_seed_set == FALSE) {
+ /* Initialize the hash seed and state at startup. This must be
+ * done very early, before ANY hashes are constructed, and once
+ * setup is fixed for the lifetime of the process.
+ *
+ * If you decide to disable the seeding process you should choose
+ * a suitable seed yourself and define PERL_HASH_SEED to a well chosen
+ * string. See hv_func.h for details.
+ */
+#if defined(USE_HASH_SEED)
+ /* get the hash seed from the environment or from an RNG */
Perl_get_hash_seed(aTHX_ PL_hash_seed);
+#else
+ /* they want a hard coded seed, check that it is long enough */
+ assert( strlen(PERL_HASH_SEED) >= PERL_HASH_SEED_BYTES );
+#endif
+
+ /* now we use the chosen seed to initialize the state -
+ * in some configurations this may be a relatively speaking
+ * expensive operation, but we only have to do it once at startup */
+ PERL_HASH_SEED_STATE(PERL_HASH_SEED,PL_hash_state);
+
+#ifdef PERL_USE_SINGLE_CHAR_HASH_CACHE
+ /* we can build a special cache for 0/1 byte keys, if people choose
+ * I suspect most of the time it is not worth it */
+ {
+ char str[2]="\0";
+ int i;
+ for (i=0;i<256;i++) {
+ str[0]= i;
+ PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[i],str,1);
+ }
+ PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[256],str,0);
+ }
+#endif
+ /* at this point we have initialezed the hash function, and we can start
+ * constructing hashes */
PL_hash_seed_set= TRUE;
}
-#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
- /* 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();
-
- HvSHAREKEYS_off(PL_strtab); /* mandatory */
- hv_ksplit(PL_strtab, 512);
+ /* 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");
}
}
-#else
-# ifdef HAS_GETPAGESIZE
+#elif defined(HAS_GETPAGESIZE)
PL_mmap_page_size = getpagesize();
-# else
-# if defined(I_SYS_PARAM) && defined(PAGESIZE)
+#elif defined(I_SYS_PARAM) && defined(PAGESIZE)
PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
-# endif
-# endif
#endif
if (PL_mmap_page_size <= 0)
Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
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
ENTER;
}
#endif
/*
-=for apidoc perl_destruct
-
-Shuts down a Perl interpreter. See L<perlembed>.
+=for apidoc Am|int|perl_destruct|PerlInterpreter *my_perl
+
+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_destruct(pTHXx)
{
dVAR;
- VOL signed char destruct_level; /* see possible values in intrpvar.h */
+ volatile signed char destruct_level; /* see possible values in intrpvar.h */
HV *hv;
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
pid_t child;
assert(PL_scopestack_ix == 0);
/* Need to flush since END blocks can produce output */
+ /* flush stdout separately, since we can identify it */
+#ifdef USE_PERLIO
+ {
+ PerlIO *stdo = PerlIO_stdout();
+ if (*stdo && PerlIO_flush(stdo)) {
+ PerlIO_restore_errno(stdo);
+ if (errno)
+ PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s",
+ Strerror(errno));
+ if (!STATUS_UNIX)
+ STATUS_ALL_FAILURE;
+ }
+ }
+#endif
my_fflush_all();
#ifdef PERL_TRACE_OPS
- /* If we traced all Perl OP usage, report and clean up */
+ /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */
+ {
+ const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS");
+ UV uv;
+
+ if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL)
+ || !(uv > 0))
+ goto no_trace_out;
+ }
PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
for (i = 0; i <= OP_max; ++i) {
- PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
- PL_op_exec_cnt[i] = 0;
+ if (PL_op_exec_cnt[i])
+ PerlIO_printf(Perl_debug_log, " %s: %" UVuf "\n", PL_op_name[i], PL_op_exec_cnt[i]);
}
/* Utility slot for easily doing little tracing experiments in the runloop: */
if (PL_op_exec_cnt[OP_max+1] != 0)
- PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
+ PerlIO_printf(Perl_debug_log, " SPECIAL: %" UVuf "\n", PL_op_exec_cnt[OP_max+1]);
PerlIO_printf(Perl_debug_log, "\n");
+ no_trace_out:
#endif
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;
}
PL_numeric_radix_sv = NULL;
#endif
+ 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_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);
hv = PL_defstash;
/* break ref loop *:: <=> %:: */
- (void)hv_delete(hv, "main::", 6, G_DISCARD);
+ (void)hv_deletes(hv, "main::", G_DISCARD);
PL_defstash = 0;
SvREFCNT_dec(hv);
SvREFCNT_dec(PL_curstname);
SvANY(&PL_sv_no) = NULL;
SvFLAGS(&PL_sv_no) = 0;
+ SvREFCNT(&PL_sv_zero) = 0;
+ sv_clear(&PL_sv_zero);
+ SvANY(&PL_sv_zero) = NULL;
+ SvFLAGS(&PL_sv_zero) = 0;
+
{
int i;
for (i=0; i<=2; i++) {
PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
" flags=0x%"UVxf
" refcnt=%"UVuf pTHX__FORMAT "\n"
- "\tallocated at %s:%d %s %s (parent 0x%"UVxf");"
- "serial %"UVuf"\n",
+ "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
+ "serial %" UVuf "\n",
(void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
pTHX__VALUE,
sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
}
/*
-=for apidoc perl_parse
-
-Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
+=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<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.
+
+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. 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
*/
#ifndef MULTIPLICITY
PERL_UNUSED_ARG(my_perl);
#endif
-#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
+#if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG)
{
const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
if (s && strEQ(s, "1")) {
- unsigned char *seed= PERL_HASH_SEED;
- unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
+ const unsigned char *seed= PERL_HASH_SEED;
+ const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
while (seed < seed_end) {
PerlIO_printf(Perl_debug_log, "%02x", *seed++);
PerlIO_printf(Perl_debug_log, "\n");
}
}
-#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
+#endif /* #if (defined(USE_HASH_SEED) ... */
#ifdef __amigaos4__
{
}
#endif
+ {
+ int i;
+ assert(argc >= 0);
+ for(i = 0; i != argc; i++)
+ assert(argv[i]);
+ assert(!argv[argc]);
+ }
PL_origargc = argc;
PL_origargv = argv;
* the original argv[0]. (See below for 'contiguous', though.)
* --jhi */
const char *s = NULL;
- int i;
const UV mask = ~(UV)(PTRSIZE-1);
/* Do the mask check only if the args seem like aligned. */
const UV aligned =
* like the argv[] interleaved with some other data, we are
* fine. (Did I just evoke Murphy's Law?) --jhi */
if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
+ int i;
while (*s) s++;
for (i = 1; i < PL_origargc; i++) {
if ((PL_origargv[i] == s + 1
INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
)
{
+ int i;
#ifndef OS2 /* ENVIRON is read by the kernel too. */
s = PL_origenviron[0];
while (*s) s++;
call_list(oldscope, PL_checkav);
}
ret = STATUS_EXIT;
+ if (ret == 0) ret = 0x100;
break;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
# ifdef PERL_MEM_LOG_NOIMPL
" PERL_MEM_LOG_NOIMPL"
# endif
+# ifdef PERL_OP_PARENT
+ " PERL_OP_PARENT"
+# endif
# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
" PERL_PERTURB_KEYS_DETERMINISTIC"
# endif
# ifdef PERL_USE_SAFE_PUTENV
" PERL_USE_SAFE_PUTENV"
# endif
+# ifdef SILENT_NO_TAINT_SUPPORT
+ " SILENT_NO_TAINT_SUPPORT"
+# endif
# ifdef UNLINK_ALL_VERSIONS
" UNLINK_ALL_VERSIONS"
# endif
# ifdef USE_FAST_STDIO
" USE_FAST_STDIO"
# endif
-# ifdef USE_HASH_SEED_EXPLICIT
- " USE_HASH_SEED_EXPLICIT"
-# endif
# ifdef USE_LOCALE
" USE_LOCALE"
# endif
# ifdef USE_LOCALE_CTYPE
" USE_LOCALE_CTYPE"
# endif
+# ifdef WIN32_NO_REGISTRY
+ " USE_NO_REGISTRY"
+# endif
# ifdef USE_PERL_ATOF
" USE_PERL_ATOF"
# endif
PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
sizeof(non_bincompat_options) - 1, SVs_TEMP));
-#ifdef __DATE__
-# ifdef __TIME__
+#ifndef PERL_BUILD_DATE
+# ifdef __DATE__
+# ifdef __TIME__
+# define PERL_BUILD_DATE __DATE__ " " __TIME__
+# else
+# define PERL_BUILD_DATE __DATE__
+# endif
+# endif
+#endif
+
+#ifdef PERL_BUILD_DATE
PUSHs(Perl_newSVpvn_flags(aTHX_
- STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
- SVs_TEMP));
-# else
- PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
+ STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
SVs_TEMP));
-# endif
#else
PUSHs(&PL_sv_undef);
#endif
}
}
+#ifndef NO_PERL_INTERNAL_RAND_SEED
+ /* If we're not set[ug]id, we might have honored
+ PERL_INTERNAL_RAND_SEED in perl_construct().
+ At this point command-line options have been parsed, so if
+ we're now tainting and not set[ug]id re-seed.
+ This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
+ but avoids duplicating the logic from perl_construct().
+ */
+ if (PL_tainting &&
+ PerlProc_getuid() == PerlProc_geteuid() &&
+ PerlProc_getgid() == PerlProc_getegid()) {
+ Perl_drand48_init_r(&PL_internal_random_state, seed());
+ }
+#endif
+
/* Set $^X early so that it can be used for relocatable paths in @INC */
/* and for SITELIB_EXP in USE_SITECUSTOMIZE */
assert (!TAINT_get);
it should be reported immediately as a build failure. */
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
Perl_newSVpvf(aTHX_
- "BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; "
+ "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
"do {local $!; -f $f }"
" and do $f || die $@ || qq '$f: $!' }",
0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
/* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
* or explicitly in some platforms.
+ * PL_utf8locale is conditionally turned on by
* locale.c:Perl_init_i18nl10n() if the environment
* look like the user wants to use UTF-8. */
#if defined(__SYMBIAN32__)
SETERRNO(0,SS_NORMAL);
if (yyparse(GRAMPROG) || PL_parser->error_count) {
- if (PL_minus_c)
- Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
- else {
- Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
- PL_origfilename);
- }
+ abort_execution("", PL_origfilename);
}
CopLINE_set(PL_curcop, 0);
SET_CURSTASH(PL_defstash);
}
/*
-=for apidoc perl_run
-
-Tells a Perl interpreter to run. See L<perlembed>.
+=for apidoc Am|int|perl_run|PerlInterpreter *my_perl
+
+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
*/
perl_run(pTHXx)
{
I32 oldscope;
- int ret = 0;
+ int ret = 0, exit_called = 0;
dJMPENV;
PERL_ARGS_ASSERT_PERL_RUN;
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;
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) {
PERL_ARGS_ASSERT_GET_CVN_FLAGS;
+ if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
+ return (CV*)SvRV((SV *)gv);
+
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
*/
I32
-Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
+Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
/* See G_* flags in cop.h */
{
- dVAR; dSP;
+ dVAR;
LOGOP myop; /* fake syntax tree node */
METHOP method_op;
I32 oldmark;
- VOL I32 retval = 0;
- I32 oldscope;
+ volatile I32 retval = 0;
bool oldcatch = CATCH_GET;
int ret;
OP* const oldop = PL_op;
SAVEOP();
PL_op = (OP*)&myop;
- EXTEND(PL_stack_sp, 1);
- if (!(flags & G_METHOD_NAMED))
- *++PL_stack_sp = sv;
+ if (!(flags & G_METHOD_NAMED)) {
+ dSP;
+ EXTEND(SP, 1);
+ PUSHs(sv);
+ PUTBACK;
+ }
oldmark = TOPMARK;
- oldscope = PL_scopestack_ix;
if (PERLDB_SUB && PL_curstash != PL_debstash
/* Handle first BEGIN of -d. */
CATCH_SET(oldcatch);
}
else {
+ I32 old_cxix;
myop.op_other = (OP*)&myop;
- PL_markstack_ptr--;
- create_eval_scope(flags|G_FAKINGEVAL);
- PL_markstack_ptr++;
+ (void)POPMARK;
+ old_cxix = cxstack_ix;
+ create_eval_scope(NULL, flags|G_FAKINGEVAL);
+ INCMARK;
JMPENV_PUSH(ret);
break;
}
- if (PL_scopestack_ix > oldscope)
+ /* if we croaked, depending on how we croaked the eval scope
+ * may or may not have already been popped */
+ if (cxstack_ix > old_cxix) {
+ assert(cxstack_ix == old_cxix + 1);
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
delete_eval_scope();
+ }
JMPENV_POP;
}
/* See G_* flags in cop.h */
{
dVAR;
- dSP;
UNOP myop; /* fake syntax tree node */
- VOL I32 oldmark = SP - PL_stack_base;
- VOL I32 retval = 0;
+ volatile I32 oldmark;
+ volatile I32 retval = 0;
int ret;
OP* const oldop = PL_op;
dJMPENV;
SAVEOP();
PL_op = (OP*)&myop;
Zero(&myop, 1, UNOP);
- EXTEND(PL_stack_sp, 1);
- *++PL_stack_sp = sv;
+ {
+ dSP;
+ oldmark = SP - PL_stack_base;
+ EXTEND(SP, 1);
+ PUSHs(sv);
+ PUTBACK;
+ }
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
/* fail now; otherwise we could fail after the JMPENV_PUSH but
- * before a PUSHEVAL, which corrupts the stack after a croak */
+ * before a cx_pusheval(), which corrupts the stack after a croak */
TAINT_PROPER("eval_sv()");
JMPENV_PUSH(ret);
" M trace smart match resolution\n"
" 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",
NULL
};
UV uv = 0;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL";
+ static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
s--;
}
PL_rs = newSVpvs("");
- SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
- tmps = (U8*)SvPVX(PL_rs);
+ tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
uvchr_to_utf8(tmps, rschar);
SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
SvUTF8_on(PL_rs);
case 'i':
Safefree(PL_inplace);
-#if defined(__CYGWIN__) /* do backup extension automagically */
- if (*(s+1) == '\0') {
- PL_inplace = savepvs(".bak");
- return s+1;
- }
-#endif /* __CYGWIN__ */
{
const char * const start = ++s;
while (*s && !isSPACE(*s))
PL_inplace = savepvn(start, s - start);
}
- if (*s) {
- ++s;
- if (*s == '-') /* Additional switches on #! line. */
- s++;
- }
return s;
case 'I': /* -I handled both here and in parse_body() */
forbid_setid('I', FALSE);
"\nThis is perl " STRINGIFY(PERL_REVISION)
", version " STRINGIFY(PERL_VERSION)
", subversion " STRINGIFY(PERL_SUBVERSION)
- " (%"SVf") built for " ARCHNAME, SVfARG(level)
+ " (%" SVf ") built for " ARCHNAME, SVfARG(level)
);
SvREFCNT_dec_NN(level);
}
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2015, Larry Wall\n");
+ "\n\nCopyright 1987-2017, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\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. */
because otherwise all we do is delete "main" from it as a consequence
of the SvREFCNT_dec, only to add it again with hv_name_set */
SvREFCNT_dec(GvHV(gv));
- hv_name_set(PL_defstash, "main", 4, 0);
+ hv_name_sets(PL_defstash, "main", 0);
GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
SvREADONLY_on(gv);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
CLEAR_ERRSV();
- SET_CURSTASH(PL_defstash);
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
/* if find_script() returns, it returns a malloc()-ed value */
scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
- if (strnEQ(scriptname, "/dev/fd/", 8)
+ if (strBEGINs(scriptname, "/dev/fd/")
&& isDIGIT(scriptname[8])
&& grok_atoUV(scriptname + 8, &uv, &s)
&& uv <= PERL_INT_MAX
};
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(0600);
- 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);
-#else
-# ifdef HAS_MKTEMP
- scriptname = mktemp(tmpname);
- if (!scriptname)
- Perl_croak(aTHX_ err);
-# endif
-#endif
}
#endif
rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
#ifdef FAKE_BIT_BUCKET
- if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
- sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
- && strlen(scriptname) == sizeof(tmpname) - 1) {
+ if ( strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX)
+ && strlen(scriptname) == sizeof(tmpname) - 1)
+ {
unlink(scriptname);
}
scriptname = BIT_BUCKET;
if (!rsfp) {
/* PSz 16 Sep 03 Keep neat error message */
if (PL_e_script)
- Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
+ Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
else
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
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
return rsfp;
}
+/* In the days of suidperl, we refused to execute a setuid script stored on
+ * a filesystem mounted nosuid and/or noexec. This meant that we probed for the
+ * existence of the appropriate filesystem-statting function, and behaved
+ * accordingly. But even though suidperl is long gone, we must still include
+ * those probes for the benefit of modules like Filesys::Df, which expect the
+ * results of those probes to be stored in %Config; see RT#126368. So mention
+ * the relevant cpp symbols here, to ensure that metaconfig will include their
+ * probes in the generated Configure:
+ *
+ * I_SYSSTATVFS HAS_FSTATVFS
+ * I_SYSMOUNT
+ * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
+ * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
+ */
+
+
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
/* Don't even need this function. */
#else
if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
dVAR;
int fd = PerlIO_fileno(rsfp);
- if (fd < 0) {
- Perl_croak(aTHX_ "Illegal suidscript");
- } else {
- if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */
- Perl_croak(aTHX_ "Illegal suidscript");
- }
+ Stat_t statbuf;
+ if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
+ Perl_croak_nocontext( "Illegal suidscript");
}
- if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+ if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
- (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+ (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
)
if (!PL_do_undump)
Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
if (*s++ == '-') {
while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
|| s2[-1] == '_') s2--;
- if (strnEQ(s2-4,"perl",4))
+ if (strBEGINs(s2-4,"perl"))
while ((s = moreswitches(s)))
;
}
void
Perl_init_stacks(pTHX)
{
+ SSize_t size;
+
/* start with 128-item stack and 8K cxstack */
PL_curstackinfo = new_stackinfo(REASONABLE(128),
REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
PL_curstackinfo->si_type = PERLSI_MAIN;
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+ PL_curstackinfo->si_stack_hwm = 0;
+#endif
PL_curstack = PL_curstackinfo->si_stack;
PL_mainstack = PL_curstack; /* remember in case we switch stacks */
PL_scopestack_ix = 0;
PL_scopestack_max = REASONABLE(32);
- Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY);
+ size = REASONABLE_but_at_least(128,SS_MAXPUSH);
+ Newx(PL_savestack, size, ANY);
PL_savestack_ix = 0;
- PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH);
+ /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
+ PL_savestack_max = size - SS_MAXPUSH;
}
#undef REASONABLE
PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
PL_toptarget = newSV_type(SVt_PVIV);
- sv_setpvs(PL_toptarget, "");
+ SvPVCLEAR(PL_toptarget);
PL_bodytarget = newSV_type(SVt_PVIV);
- sv_setpvs(PL_bodytarget, "");
+ SvPVCLEAR(PL_bodytarget);
PL_formtarget = PL_bodytarget;
TAINT;
}
if (env) {
char *s, *old_var;
+ STRLEN nlen;
SV *sv;
+ HV *dups = newHV();
+
for (; *env; env++) {
old_var = *env;
if (!(s = strchr(old_var,'=')) || s == old_var)
continue;
+ nlen = s - old_var;
#if defined(MSDOS) && !defined(DJGPP)
*s = '\0';
(void)strupr(old_var);
*s = '=';
#endif
- sv = newSVpv(s+1, 0);
- (void)hv_store(hv, old_var, s - old_var, sv, 0);
+ if (hv_exists(hv, old_var, nlen)) {
+ const char *name = savepvn(old_var, nlen);
+
+ /* make sure we use the same value as getenv(), otherwise code that
+ uses getenv() (like setlocale()) might see a different value to %ENV
+ */
+ sv = newSVpv(PerlEnv_getenv(name), 0);
+
+ /* keep a count of the dups of this name so we can de-dup environ later */
+ if (hv_exists(dups, name, nlen))
+ ++SvIVX(*hv_fetch(dups, name, nlen, 0));
+ else
+ (void)hv_store(dups, name, nlen, newSViv(1), 0);
+
+ Safefree(name);
+ }
+ else {
+ sv = newSVpv(s+1, 0);
+ }
+ (void)hv_store(hv, old_var, nlen, sv, 0);
if (env_is_not_environ)
mg_set(sv);
}
+ if (HvKEYS(dups)) {
+ /* environ has some duplicate definitions, remove them */
+ HE *entry;
+ hv_iterinit(dups);
+ while ((entry = hv_iternext_flags(dups, 0))) {
+ STRLEN nlen;
+ const char *name = HePV(entry, nlen);
+ IV count = SvIV(HeVAL(entry));
+ IV i;
+ SV **valp = hv_fetch(hv, name, nlen, 0);
+
+ assert(valp);
+
+ /* try to remove any duplicate names, depending on the
+ * implementation used in my_setenv() the iteration might
+ * not be necessary, but let's be safe.
+ */
+ for (i = 0; i < count; ++i)
+ my_setenv(name, 0);
+
+ /* and set it back to the value we set $ENV{name} to */
+ my_setenv(name, SvPV_nolen(*valp));
+ }
+ }
+ SvREFCNT_dec_NN(dups);
}
#endif /* USE_ENVIRON_ARRAY */
#endif /* !PERL_MICRO */
*/
char buf[256];
int idx = 0;
- if (my_trnlnm("PERL5LIB",buf,0))
+ if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
do {
incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
- } while (my_trnlnm("PERL5LIB",buf,++idx));
+ } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
else {
- while (my_trnlnm("PERLLIB",buf,idx++))
+ while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
incpush_use_sep(buf, 0, 0);
}
#endif /* VMS */
/* 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
-
-#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
+ 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_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);
-#else
-# ifdef 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
-#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
+#endif /* !PERL_IS_MINIPERL */
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)
+#if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
+ const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
+ if (unsafe && strEQ(unsafe, "1"))
#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 (my_trnlnm("PERL5LIB",buf,0))
- do {
- incpush_use_sep(buf, 0,
- INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
- } while (my_trnlnm("PERL5LIB",buf,++idx));
-#endif /* VMS */
+ S_incpush(aTHX_ STR_WITH_LEN("."), 0);
}
-
-/* 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)
- S_incpush(aTHX_ STR_WITH_LEN("."), 0);
}
#if defined(DOSISH) || defined(__SYMBIAN32__)
# define PERLLIB_SEP ';'
+#elif defined(__VMS)
+# define PERLLIB_SEP PL_perllib_sep
#else
-# if defined(VMS)
-# define PERLLIB_SEP '|'
-# else
# define PERLLIB_SEP ':'
-# endif
#endif
#ifndef PERLLIB_MANGLE
# define PERLLIB_MANGLE(s,n) (s)
*/
const char *libpath = SvPVX(libdir);
STRLEN libpath_len = SvCUR(libdir);
- if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
+ if (memBEGINs(libpath, libpath_len, ".../")) {
/* Game on! */
SV * const caret_X = get_sv("\030", 0);
/* Going to use the SV just as a scratch buffer holding a C
libpath = SvPVX(libdir);
libpath_len = SvCUR(libdir);
- /* This would work more efficiently with memrchr, but as it's
- only a GNU extension we'd need to probe for it and
- implement our own. Not hard, but maybe not worth it? */
-
prefix = SvPVX(prefix_sv);
- lastslash = strrchr(prefix, '/');
+ lastslash = (char *) my_memrchr(prefix, '/',
+ SvEND(prefix_sv) - prefix);
/* First time in with the *lastslash = '\0' we just wipe off
the trailing /perl from (say) /usr/foo/bin/perl
if (lastslash) {
SV *tempsv;
while ((*lastslash = '\0'), /* Do that, come what may. */
- (libpath_len >= 3 && memEQ(libpath, "../", 3)
- && (lastslash = strrchr(prefix, '/')))) {
+ ( memBEGINs(libpath, libpath_len, "../")
+ && (lastslash =
+ (char *) my_memrchr(prefix, '/',
+ SvEND(prefix_sv) - prefix))))
+ {
if (lastslash[1] == '\0'
|| (lastslash[1] == '.'
&& (lastslash[2] == '/' /* ends "/." */
while (PL_scopestack_ix > oldscope)
LEAVE;
JMPENV_POP;
- Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
+ Perl_croak(aTHX_ "%" SVf, SVfARG(atsv));
}
break;
case 1:
#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)
}
POPSTACK_TO(PL_mainstack);
- dounwind(-1);
+ if (cxstack_ix >= 0) {
+ dounwind(-1);
+ cx_popblock(cxstack);
+ }
LEAVE_SCOPE(0);
JMPENV_JUMP(2);
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;
https://perl5.git.perl.org / perl5.git / blobdiff