#include "nwutil.h"
#endif
-#ifdef USE_KERN_PROC_PATHNAME
-# include <sys/sysctl.h>
-#endif
-
-#ifdef USE_NSGETEXECUTABLEPATH
-# include <mach-o/dyld.h>
-#endif
-
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
# ifdef I_SYSUIO
# include <sys/uio.h>
{
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
if (s) {
- const int i = atoi(s);
+ const int i = atoi(s);
#ifdef DEBUGGING
if (destruct_level < i) destruct_level = i;
#endif
#ifdef PERL_TRACK_MEMPOOL
- /* RT #114496, for perl_free */
- PL_perl_destruct_level = i;
+ /* RT #114496, for perl_free */
+ PL_perl_destruct_level = i;
#endif
}
}
/* ensure comppad/curpad to refer to main's pad */
if (CvPADLIST(PL_main_cv)) {
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
+ PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
}
op_free(PL_main_root);
PL_main_root = NULL;
return STATUS_EXIT;
}
+ /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
+
#ifdef USE_ITHREADS
/* the syntax tree is shared between clones
* so op_free(PL_main_root) only ReREFCNT_dec's
PL_initav = NULL;
/* shortcuts just get cleared */
- PL_envgv = NULL;
- PL_incgv = NULL;
PL_hintgv = NULL;
PL_errgv = NULL;
- PL_argvgv = NULL;
PL_argvoutgv = NULL;
PL_stdingv = NULL;
PL_stderrgv = NULL;
PL_last_in_gv = NULL;
- PL_replgv = NULL;
- PL_DBgv = NULL;
- PL_DBline = NULL;
- PL_DBsub = NULL;
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
+ SvREFCNT_dec(PL_envgv);
+ SvREFCNT_dec(PL_incgv);
+ SvREFCNT_dec(PL_argvgv);
+ SvREFCNT_dec(PL_replgv);
+ SvREFCNT_dec(PL_DBgv);
+ SvREFCNT_dec(PL_DBline);
+ SvREFCNT_dec(PL_DBsub);
+ PL_envgv = NULL;
+ PL_incgv = NULL;
+ PL_argvgv = NULL;
+ PL_replgv = NULL;
+ PL_DBgv = NULL;
+ PL_DBline = NULL;
+ PL_DBsub = NULL;
+
SvREFCNT_dec(PL_argvout_stack);
PL_argvout_stack = NULL;
SvREFCNT_dec(PL_utf8_idstart);
SvREFCNT_dec(PL_utf8_idcont);
SvREFCNT_dec(PL_utf8_foldclosures);
+ SvREFCNT_dec(PL_AboveLatin1);
+ SvREFCNT_dec(PL_UpperLatin1);
+ SvREFCNT_dec(PL_Latin1);
+ SvREFCNT_dec(PL_NonL1NonFinalFold);
+ SvREFCNT_dec(PL_HasMultiCharFold);
PL_utf8_mark = NULL;
PL_utf8_toupper = NULL;
PL_utf8_totitle = NULL;
PL_utf8_idstart = NULL;
PL_utf8_idcont = NULL;
PL_utf8_foldclosures = NULL;
+ PL_AboveLatin1 = NULL;
+ PL_HasMultiCharFold = NULL;
+ PL_Latin1 = NULL;
+ PL_NonL1NonFinalFold = NULL;
+ PL_UpperLatin1 = NULL;
for (i = 0; i < POSIX_CC_COUNT; i++) {
SvREFCNT_dec(PL_Posix_ptrs[i]);
PL_Posix_ptrs[i] = NULL;
++PL_exitlistlen;
}
-STATIC void
-S_set_caret_X(pTHX) {
- dVAR;
- GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
- if (tmpgv) {
- SV *const caret_x = GvSV(tmpgv);
-#if defined(OS2)
- sv_setpv(caret_x, os2_execname(aTHX));
-#else
-# ifdef USE_KERN_PROC_PATHNAME
- size_t size = 0;
- int mib[4];
- mib[0] = CTL_KERN;
- mib[1] = KERN_PROC;
- mib[2] = KERN_PROC_PATHNAME;
- mib[3] = -1;
-
- if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
- && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
- sv_grow(caret_x, size);
-
- if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
- && size > 2) {
- SvPOK_only(caret_x);
- SvCUR_set(caret_x, size - 1);
- SvTAINT(caret_x);
- return;
- }
- }
-# elif defined(USE_NSGETEXECUTABLEPATH)
- char buf[1];
- uint32_t size = sizeof(buf);
-
- _NSGetExecutablePath(buf, &size);
- if (size < MAXPATHLEN * MAXPATHLEN) {
- sv_grow(caret_x, size);
- if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
- char *const tidied = realpath(SvPVX(caret_x), NULL);
- if (tidied) {
- sv_setpv(caret_x, tidied);
- free(tidied);
- } else {
- SvPOK_only(caret_x);
- SvCUR_set(caret_x, size);
- }
- return;
- }
- }
-# elif defined(HAS_PROCSELFEXE)
- char buf[MAXPATHLEN];
- int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
-
- /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
- includes a spurious NUL which will cause $^X to fail in system
- or backticks (this will prevent extensions from being built and
- many tests from working). readlink is not meant to add a NUL.
- Normal readlink works fine.
- */
- if (len > 0 && buf[len-1] == '\0') {
- len--;
- }
-
- /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
- returning the text "unknown" from the readlink rather than the path
- to the executable (or returning an error from the readlink). Any
- valid path has a '/' in it somewhere, so use that to validate the
- result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
- */
- if (len > 0 && memchr(buf, '/', len)) {
- sv_setpvn(caret_x, buf, len);
- return;
- }
-# endif
- /* Fallback to this: */
- sv_setpv(caret_x, PL_origargv[0]);
-#endif
- }
-}
-
/*
=for apidoc perl_parse
init_ids();
assert (!TAINT_get);
TAINT;
- S_set_caret_X(aTHX);
+ set_caret_X();
TAINT_NOT;
init_postdump_symbols(argc,argv,env);
return 0;
/* and for SITELIB_EXP in USE_SITECUSTOMIZE */
assert (!TAINT_get);
TAINT;
- S_set_caret_X(aTHX);
+ set_caret_X();
TAINT_NOT;
#if defined(USE_SITECUSTOMIZE)
PERL_ARGS_ASSERT_REQUIRE_PV;
PUSHSTACKi(PERLSI_REQUIRE);
- PUTBACK;
sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
eval_sv(sv_2mortal(sv), G_DISCARD);
- SPAGAIN;
POPSTACK;
}
S_minus_v(pTHX)
{
PerlIO * PIO_stdout;
- if (!sv_derived_from(PL_patchlevel, "version"))
- upg_version(PL_patchlevel, TRUE);
{
- SV* level= vstringify(PL_patchlevel);
+ const char * const level_str = "v" PERL_VERSION_STRING;
+ const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
#ifdef PERL_PATCHNUM
+ SV* level;
# ifdef PERL_GIT_UNCOMMITTED_CHANGES
- SV *num = newSVpvs(PERL_PATCHNUM "*");
+ static const char num [] = PERL_PATCHNUM "*";
# else
- SV *num = newSVpvs(PERL_PATCHNUM);
+ static const char num [] = PERL_PATCHNUM;
# endif
{
- STRLEN level_len, num_len;
- char * level_str, * num_str;
- num_str = SvPV(num, num_len);
- level_str = SvPV(level, level_len);
- if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) {
- SvREFCNT_dec(level);
- level= num;
+ const STRLEN num_len = sizeof(num)-1;
+ /* A very advanced compiler would fold away the strnEQ
+ and this whole conditional, but most (all?) won't do it.
+ SV level could also be replaced by with preprocessor
+ catenation.
+ */
+ if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
+ /* per 46807d8e80, PERL_PATCHNUM is outside of the control
+ of the interp so it might contain format characters
+ */
+ level = newSVpvn(num, num_len);
} else {
- Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
- SvREFCNT_dec(num);
+ level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
}
}
- #endif
+#else
+ SV* level = newSVpvn(level_str, level_len);
+#endif /* #ifdef PERL_PATCHNUM */
PIO_stdout = PerlIO_stdout();
PerlIO_printf(PIO_stdout,
"\nThis is perl " STRINGIFY(PERL_REVISION)
", subversion " STRINGIFY(PERL_SUBVERSION)
" (%"SVf") built for " ARCHNAME, level
);
- SvREFCNT_dec(level);
+ SvREFCNT_dec_NN(level);
}
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
GvMULTI_on(PL_incgv);
PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
+ SvREFCNT_inc_simple_void(PL_hintgv);
GvMULTI_on(PL_hintgv);
PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
SvREFCNT_inc_simple_void(PL_defgv);
- PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
+ PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
SvREFCNT_inc_simple_void(PL_errgv);
GvMULTI_on(PL_errgv);
PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
+ SvREFCNT_inc_simple_void(PL_replgv);
GvMULTI_on(PL_replgv);
(void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
#ifdef PERL_DONT_CREATE_GVSV
PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
Perl_init_dbargs(aTHX);
- PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
- PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
- PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
+ PL_DBgv = MUTABLE_GV(
+ SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
+ );
+ PL_DBline = MUTABLE_GV(
+ SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
+ );
+ PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
+ gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
+ ));
PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsingle))
sv_setiv(PL_DBsingle, 0);
#ifndef STRESS_REALLOC
#define REASONABLE(size) (size)
+#define REASONABLE_but_at_least(size,min) (size)
#else
#define REASONABLE(size) (1) /* unreasonable */
+#define REASONABLE_but_at_least(size,min) (min)
#endif
void
PL_scopestack_ix = 0;
PL_scopestack_max = REASONABLE(32);
- Newx(PL_savestack,REASONABLE(128),ANY);
+ Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY);
PL_savestack_ix = 0;
- PL_savestack_max = REASONABLE(128);
+ PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH);
}
#undef REASONABLE
}
}
if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
+ SvREFCNT_inc_simple_void_NN(PL_argvgv);
GvMULTI_on(PL_argvgv);
- (void)gv_AVadd(PL_argvgv);
av_clear(GvAVn(PL_argvgv));
for (; argc > 0; argc--,argv++) {
SV * const sv = newSVpv(argv[0],0);
- av_push(GvAVn(PL_argvgv),sv);
+ av_push(GvAV(PL_argvgv),sv);
if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
SvUTF8_on(sv);
if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
HV *hv;
bool env_is_not_environ;
+ SvREFCNT_inc_simple_void_NN(PL_envgv);
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, NULL, PERL_MAGIC_env);
if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
len = strlen(unix);
- while (unix[len-1] == '/') len--; /* Cosmetic */
+ while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */
sv_usepvn(libdir,unix,len);
}
else
/* finally add this lib directory at the end of @INC */
if (unshift) {
#ifdef PERL_IS_MINIPERL
- const U32 extra = 0;
+ const Size_t extra = 0;
#else
- U32 extra = av_len(av) + 1;
+ Size_t extra = av_len(av) + 1;
#endif
av_unshift(inc, extra + push_basedir);
if (push_basedir)
Perl_my_exit(pTHX_ U32 status)
{
dVAR;
+ if (PL_exit_flags & PERL_EXIT_ABORT) {
+ abort();
+ }
+ if (PL_exit_flags & PERL_EXIT_WARN) {
+ PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
+ Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status);
+ PL_exit_flags &= ~PERL_EXIT_ABORT;
+ }
switch (status) {
case 0:
STATUS_ALL_SUCCESS;
STATUS_UNIX_SET(255);
}
#endif
+ if (PL_exit_flags & PERL_EXIT_ABORT) {
+ abort();
+ }
+ if (PL_exit_flags & PERL_EXIT_WARN) {
+ PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
+ Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue);
+ PL_exit_flags &= ~PERL_EXIT_ABORT;
+ }
my_exit_jump();
}