*
* 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 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)
OP_REFCNT_INIT;
OP_CHECK_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_ids();
+ S_fixup_platform_bugs();
+
JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
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);
+#ifdef USE_THREAD_SAFE_LOCALE
+ PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
+#endif
ENTER;
}
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);
+ 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, "\n");
+ no_trace_out:
#endif
PL_XPosix_ptrs[i] = NULL;
}
PL_GCB_invlist = NULL;
+ PL_LB_invlist = NULL;
PL_SB_invlist = NULL;
PL_WB_invlist = NULL;
+#ifdef USE_THREAD_SAFE_LOCALE
+ if (PL_C_locale_obj) {
+ /* Make sure we aren't using the locale space we are about to free */
+ uselocale(LC_GLOBAL_LOCALE);
+
+ freelocale(PL_C_locale_obj);
+ PL_C_locale_obj = (locale_t) NULL;
+ }
+#endif
+
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = NULL;
# 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
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__),
+ STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
SVs_TEMP));
-# else
- PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
- SVs_TEMP));
-# endif
#else
PUSHs(&PL_sv_undef);
#endif
METHOP method_op;
I32 oldmark;
VOL I32 retval = 0;
- I32 oldscope;
bool oldcatch = CATCH_GET;
int ret;
OP* const oldop = PL_op;
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;
}
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);
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2015, Larry Wall\n");
+ "\n\nCopyright 1987-2016, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
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 old_umask = umask(0177);
int tmpfd = mkstemp(tmpname);
umask(old_umask);
if (tmpfd > -1) {
return rsfp;
}
+/* Mention
+ * I_SYSSTATVFS HAS_FSTATVFS
+ * I_SYSMOUNT
+ * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
+ * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
+ * here so that metaconfig picks them up. */
+
+
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
/* Don't even need this function. */
#else
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_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
}
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 */
*/
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_OLD_VERS|INCPUSH_NOT_BASEDIR);
- } while (my_trnlnm("PERL5LIB",buf,++idx));
+ } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
#endif /* VMS */
}
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
SV *atsv;
- volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
+ VOL const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
CV *cv;
STRLEN len;
int ret;
}
POPSTACK_TO(PL_mainstack);
- dounwind(-1);
+ if (cxstack_ix >= 0) {
+ dounwind(-1);
+ cx_popblock(cxstack);
+ }
LEAVE_SCOPE(0);
JMPENV_JUMP(2);
https://perl5.git.perl.org / perl5.git / blobdiff