* 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_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(). */
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);
+ 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, "\n");
+ no_trace_out:
#endif
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);
# 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
/* 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__)
(void)POPMARK;
old_cxix = cxstack_ix;
create_eval_scope(NULL, flags|G_FAKINGEVAL);
- (void)INCMARK;
+ INCMARK;
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);
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);
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,
/* 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 (strEQs(scriptname, "/dev/fd/")
&& isDIGIT(scriptname[8])
&& grok_atoUV(scriptname + 8, &uv, &s)
&& uv <= PERL_INT_MAX
if (*s++ == '-') {
while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
|| s2[-1] == '_') s2--;
- if (strnEQ(s2-4,"perl",4))
+ if (strEQs(s2-4,"perl"))
while ((s = moreswitches(s)))
;
}
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 defined(DOSISH) || defined(__SYMBIAN32__)
# define PERLLIB_SEP ';'
#else
-# if defined(VMS)
-# define PERLLIB_SEP '|'
+# if defined(__VMS)
+# define PERLLIB_SEP PL_perllib_sep
# else
# define PERLLIB_SEP ':'
# endif
if (lastslash) {
SV *tempsv;
while ((*lastslash = '\0'), /* Do that, come what may. */
- (libpath_len >= 3 && memEQ(libpath, "../", 3)
+ (libpath_len >= 3 && _memEQs(libpath, "../")
&& (lastslash = strrchr(prefix, '/')))) {
if (lastslash[1] == '\0'
|| (lastslash[1] == '.'
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;