*
* 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.
}
void
-Perl_sys_term()
+Perl_sys_term(void)
{
dVAR;
if (!PL_veto_cleanup) {
Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
-#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
- _dyld_lookup_and_bind
- ("__environ", (unsigned long *) &environ_pointer, NULL);
-#endif /* environ */
-
#ifndef PERL_MICRO
# ifdef USE_ENVIRON_ARRAY
PL_origenviron = environ;
PL_stashcache = newHV();
PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
- PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
#ifdef HAS_MMAP
if (!PL_mmap_page_size) {
/* 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);
+
ENTER;
}
{
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
if (s) {
- const int i = atoi(s);
+ int i;
+ if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
+ i = -1;
+ } else {
+ UV uv;
+ if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
+ i = (int)uv;
+ else
+ i = 0;
+ }
#ifdef DEBUGGING
if (destruct_level < i) destruct_level = i;
#endif
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
msg.msg_name = NULL;
msg.msg_namelen = 0;
msg.msg_iov = vec;
- msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
+ msg.msg_iovlen = C_ARRAY_LENGTH(vec);
vec[0].iov_base = (void*)⌖
vec[0].iov_len = sizeof(target);
Safefree(PL_inplace);
PL_inplace = NULL;
SvREFCNT_dec(PL_patchlevel);
- SvREFCNT_dec(PL_apiversion);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
+ PL_DBsingle_iv = 0;
+ PL_DBtrace_iv = 0;
+ PL_DBsignal_iv = 0;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
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_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_Posix_ptrs[i]);
- PL_Posix_ptrs[i] = NULL;
-
- SvREFCNT_dec(PL_L1Posix_ptrs[i]);
- PL_L1Posix_ptrs[i] = NULL;
-
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;
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
TAINTING_set(FALSE);
TAINT_WARN_set(FALSE);
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
- PL_debug = 0;
DEBUG_P(debprofdump());
+ PL_debug = 0;
+
#ifdef USE_REENTRANT_API
Perl_reentrant_free(aTHX);
#endif
+ /* These all point to HVs that are about to be blown away.
+ Code in core and on CPAN assumes that if the interpreter is re-started
+ that they will be cleanly NULL or pointing to a valid HV. */
+ PL_custom_op_names = NULL;
+ PL_custom_op_descs = NULL;
+ PL_custom_ops = NULL;
+
sv_free_arenas();
while (PL_regmatch_slab) {
"free this thread's memory\n");
PL_debug &= ~ DEBUG_m_FLAG;
}
- while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
- safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+ while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
+ char * next = (char *)(aTHXx->Imemory_debug_header.next);
+ Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
+ safesysfree(ptr);
+ }
PL_debug = old_debug;
}
}
void
Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
{
- dVAR;
Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
PL_exitlist[PL_exitlistlen].fn = fn;
PL_exitlist[PL_exitlistlen].ptr = ptr;
{
const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- if (s && (atoi(s) == 1)) {
- unsigned char *seed= PERL_HASH_SEED;
- unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
+ if (s && strEQ(s, "1")) {
+ 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++);
}
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
+
+#ifdef __amigaos4__
+ {
+ struct NameTranslationInfo nti;
+ __translate_amiga_to_unix_path_name(&argv[0],&nti);
+ }
+#endif
+
PL_origargc = argc;
PL_origargv = argv;
* --jhi */
const char *s = NULL;
int i;
- const UV mask =
- ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
+ const UV mask = ~(UV)(PTRSIZE-1);
/* Do the mask check only if the args seem like aligned. */
const UV aligned =
(mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
break;
case 1:
STATUS_ALL_FAILURE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 2:
/* my_exit() was called */
while (PL_scopestack_ix > oldscope)
# ifdef NO_TAINT_SUPPORT
" NO_TAINT_SUPPORT"
# endif
+# ifdef PERL_BOOL_AS_CHAR
+ " PERL_BOOL_AS_CHAR"
+# endif
+# ifdef PERL_COPY_ON_WRITE
+ " PERL_COPY_ON_WRITE"
+# endif
# ifdef PERL_DISABLE_PMC
" PERL_DISABLE_PMC"
# endif
# ifdef PERL_MEM_LOG_NOIMPL
" PERL_MEM_LOG_NOIMPL"
# endif
-# ifdef PERL_NEW_COPY_ON_WRITE
- " PERL_NEW_COPY_ON_WRITE"
-# endif
# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
" PERL_PERTURB_KEYS_DETERMINISTIC"
# 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
# endif
;
PERL_UNUSED_ARG(cv);
- PERL_UNUSED_ARG(items);
+ PERL_UNUSED_VAR(items);
EXTEND(SP, entries);
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
int argc = PL_origargc;
char **argv = PL_origargv;
const char *scriptname = NULL;
- VOL bool dosearch = FALSE;
+ bool dosearch = FALSE;
char c;
bool doextract = FALSE;
const char *cddir = NULL;
break;
case 't':
-#if SILENT_NO_TAINT_SUPPORT
+#if defined(SILENT_NO_TAINT_SUPPORT)
/* silently ignore */
-#elif NO_TAINT_SUPPORT
+#elif defined(NO_TAINT_SUPPORT)
Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
s++;
goto reswitch;
case 'T':
-#if SILENT_NO_TAINT_SUPPORT
+#if defined(SILENT_NO_TAINT_SUPPORT)
/* silently ignore */
-#elif NO_TAINT_SUPPORT
+#elif defined(NO_TAINT_SUPPORT)
Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
case 'E':
PL_minus_E = TRUE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'e':
forbid_setid('e', FALSE);
if (!PL_e_script) {
if (strEQ(s, "help"))
usage();
s--;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
}
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
+ /* s points to static memory in getenv(), which may be overwritten at
+ * any time; use a mortal copy instead */
+ s = SvPVX(sv_2mortal(newSVpv(s, 0)));
+
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
-#if SILENT_NO_TAINT_SUPPORT
+#if defined(SILENT_NO_TAINT_SUPPORT)
/* silently ignore */
-#elif NO_TAINT_SUPPORT
+#elif defined(NO_TAINT_SUPPORT)
Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
}
}
if (*d == 't') {
-#if SILENT_NO_TAINT_SUPPORT
+#if defined(SILENT_NO_TAINT_SUPPORT)
/* silently ignore */
-#elif NO_TAINT_SUPPORT
+#elif defined(NO_TAINT_SUPPORT)
Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
it should be reported immediately as a build failure. */
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
Perl_newSVpvf(aTHX_
- "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
- 0, *inc0, 0,
- 0, *inc0, 0));
+ "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));
}
# else
/* SITELIB_EXP is a function call on Win32. */
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
Perl_newSVpvf(aTHX_
"BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
- 0, sitelib, 0,
- 0, sitelib, 0));
+ 0, SVfARG(sitelib), 0,
+ 0, SVfARG(sitelib), 0));
assert (SvREFCNT(sitelib_sv) == 1);
SvREFCNT_dec(sitelib_sv);
}
PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
CvUNIQUE_on(PL_compcv);
- CvPADLIST(PL_compcv) = pad_new(0);
+ CvPADLIST_set(PL_compcv, pad_new(0));
PL_isarev = newHV();
}
}
-#ifdef PERL_MAD
- {
- const char *s;
- if (!TAINTING_get &&
- (s = PerlEnv_getenv("PERL_XMLDUMP"))) {
- PL_madskills = 1;
- PL_minus_c = 1;
- if (!s || !s[0])
- PL_xmlfp = PerlIO_stdout();
- else {
- PL_xmlfp = PerlIO_open(s, "w");
- if (!PL_xmlfp)
- Perl_croak(aTHX_ "Can't open %s", s);
- }
- my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */
- }
- }
-
- {
- const char *s;
- if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
- PL_madskills = atoi(s);
- my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */
- }
- }
-#endif
lex_start(linestr_sv, rsfp, lex_start_flags);
SvREFCNT_dec(linestr_sv);
#ifdef MYMALLOC
{
const char *s;
- if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
- dump_mstats("after compilation:");
+ UV uv;
+ s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
+ if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
+ dump_mstats("after compilation:");
}
#endif
int
perl_run(pTHXx)
{
- dVAR;
I32 oldscope;
int ret = 0;
dJMPENV;
case 0: /* normal completion */
redo_body:
run_body(oldscope);
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 2: /* my_exit() */
while (PL_scopestack_ix > oldscope)
LEAVE;
STATIC void
S_run_body(pTHX_ I32 oldscope)
{
- dVAR;
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
PL_sawampersand ? "Enabling" : "Omitting",
(unsigned int)(PL_sawampersand)));
if (!PL_restartop) {
-#ifdef PERL_MAD
- if (PL_xmlfp) {
- xmldump_all();
- exit(0); /* less likely to core dump than my_exit(0) */
- }
-#endif
#ifdef DEBUGGING
if (DEBUG_x_TEST || DEBUG_B_TEST)
dump_all_perl(!DEBUG_B_TEST);
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
- sv_setiv(PL_DBsingle, 1);
+ PL_DBsingle_iv = 1;
if (PL_initav) {
PERL_SET_PHASE(PERL_PHASE_INIT);
call_list(oldscope, PL_initav);
CALLRUNOPS(aTHX);
}
my_exit(0);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
/*
Returns the HV of the specified Perl hash. C<flags> are passed to
C<gv_fetchpv>. If C<GV_ADD> is set and the
Perl variable does not exist then it will be created. If C<flags> is zero
-and the variable does not exist then NULL is returned.
+and the variable does not exist then C<NULL> is returned.
=cut
*/
=for apidoc p||call_argv
Performs a callback to the specified named and package-scoped Perl subroutine
-with C<argv> (a NULL-terminated array of strings) as arguments. See
+with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
L<perlcall>.
Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
/* See G_* flags in cop.h */
/* null terminated arg list */
{
- dVAR;
dSP;
PERL_ARGS_ASSERT_CALL_ARGV;
PUSHMARK(SP);
- if (argv) {
- while (*argv) {
- mXPUSHs(newSVpv(*argv,0));
- argv++;
- }
- PUTBACK;
+ while (*argv) {
+ mXPUSHs(newSVpv(*argv,0));
+ argv++;
}
+ PUTBACK;
return call_pv(sub_name, flags);
}
/*
=for apidoc p||call_sv
-Performs a callback to the Perl sub whose name is in the SV. See
-L<perlcall>.
+Performs a callback to the Perl sub specified by the SV.
+
+If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
+SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
+or C<SvPV(sv)> will be used as the name of the sub to call.
+
+If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
+C<SvPV(sv)> will be used as the name of the method to call.
+
+If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
+the name of the method to call.
+
+Some other values are treated specially for internal use and should
+not be depended on.
+
+See L<perlcall>.
=cut
*/
Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
/* See G_* flags in cop.h */
{
- dVAR; dSP;
+ dVAR;
LOGOP myop; /* fake syntax tree node */
- UNOP method_unop;
- SVOP method_svop;
+ METHOP method_op;
I32 oldmark;
VOL I32 retval = 0;
- I32 oldscope;
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. */
myop.op_private |= OPpENTERSUB_DB;
if (flags & (G_METHOD|G_METHOD_NAMED)) {
+ Zero(&method_op, 1, METHOP);
+ method_op.op_next = (OP*)&myop;
+ PL_op = (OP*)&method_op;
if ( flags & G_METHOD_NAMED ) {
- Zero(&method_svop, 1, SVOP);
- method_svop.op_next = (OP*)&myop;
- method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
- method_svop.op_type = OP_METHOD_NAMED;
- method_svop.op_sv = sv;
- PL_op = (OP*)&method_svop;
+ method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
+ method_op.op_type = OP_METHOD_NAMED;
+ method_op.op_u.op_meth_sv = sv;
} else {
- Zero(&method_unop, 1, UNOP);
- method_unop.op_next = (OP*)&myop;
- method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
- method_unop.op_type = OP_METHOD;
- PL_op = (OP*)&method_unop;
+ method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
+ method_op.op_type = OP_METHOD;
}
myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
myop.op_type = OP_ENTERSUB;
-
}
if (!(flags & G_EVAL)) {
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);
+ (void)INCMARK;
JMPENV_PUSH(ret);
break;
case 1:
STATUS_ALL_FAILURE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 2:
/* my_exit() was called */
SET_CURSTASH(PL_defstash);
FREETMPS;
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
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;
}
=for apidoc p||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 G_EVAL. See L<perlcall>.
+as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>.
=cut
*/
/* See G_* flags in cop.h */
{
dVAR;
- dSP;
UNOP myop; /* fake syntax tree node */
- VOL I32 oldmark = SP - PL_stack_base;
+ VOL I32 oldmark;
VOL I32 retval = 0;
int ret;
OP* const oldop = PL_op;
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);
break;
case 1:
STATUS_ALL_FAILURE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 2:
/* my_exit() was called */
SET_CURSTASH(PL_defstash);
FREETMPS;
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
/*
=for apidoc p||eval_pv
-Tells Perl to C<eval> the given string and return an SV* result.
+Tells Perl to C<eval> the given string in scalar context and return an SV* result.
=cut
*/
SV*
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
- dVAR;
SV* sv = newSVpv(p, 0);
PERL_ARGS_ASSERT_EVAL_PV;
void
Perl_require_pv(pTHX_ const char *pv)
{
- dVAR;
dSP;
SV* sv;
" q quiet - currently only suppresses the 'EXECUTING' message\n"
" 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",
NULL
};
- int i = 0;
+ UV uv = 0;
PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
+ static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBL";
for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
if (d)
- i |= 1 << (d - debopts);
+ uv |= 1 << (d - debopts);
else if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"invalid option -D%c, use -D'' to see choices\n", **s);
}
}
else if (isDIGIT(**s)) {
- i = atoi(*s);
+ const char* e;
+ if (grok_atoUV(*s, &uv, &e))
+ *s = e;
for (; isWORDCHAR(**s); (*s)++) ;
}
else if (givehelp) {
const char *const *p = usage_msgd;
while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
}
-# ifdef EBCDIC
- if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "-Dp not implemented on this platform\n");
-# endif
- return i;
+ return (int)uv; /* ignore any UV->int conversion loss */
}
#endif
s--;
}
PL_rs = newSVpvs("");
- SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
+ SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
tmps = (U8*)SvPVX(PL_rs);
uvchr_to_utf8(tmps, rschar);
- SvCUR_set(PL_rs, UNISKIP(rschar));
+ SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
SvUTF8_on(PL_rs);
}
else {
for (s++; isWORDCHAR(*s); s++) ;
#endif
return s;
+ NOT_REACHED; /* NOTREACHED */
}
case 'h':
usage();
+ NOT_REACHED; /* NOTREACHED */
+
case 'i':
Safefree(PL_inplace);
#if defined(__CYGWIN__) /* do backup extension automagically */
return s;
case 'M':
forbid_setid('M', FALSE); /* XXX ? */
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'm':
forbid_setid('m', FALSE); /* XXX ? */
if (*++s) {
return s;
case 't':
case 'T':
-#if SILENT_NO_TAINT_SUPPORT
+#if defined(SILENT_NO_TAINT_SUPPORT)
/* silently ignore */
-#elif NO_TAINT_SUPPORT
+#elif defined(NO_TAINT_SUPPORT)
Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
"\nThis is perl " STRINGIFY(PERL_REVISION)
", version " STRINGIFY(PERL_VERSION)
", subversion " STRINGIFY(PERL_SUBVERSION)
- " (%"SVf") built for " ARCHNAME, level
+ " (%"SVf") built for " ARCHNAME, SVfARG(level)
);
SvREFCNT_dec_NN(level);
}
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2013, 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");
void
Perl_my_unexec(pTHX)
{
- PERL_UNUSED_CONTEXT;
#ifdef UNEXEC
SV * prog = newSVpv(BIN_EXP, 0);
SV * file = newSVpv(PL_origfilename, 0);
/* unexec prints msg to stderr in case of failure */
PerlProc_exit(status);
#else
+ PERL_UNUSED_CONTEXT;
# ifdef VMS
lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
# elif defined(WIN32) || defined(__CYGWIN__)
- Perl_croak(aTHX_ "dump is not supported");
+ Perl_croak_nocontext("dump is not supported");
# else
ABORT(); /* for use with undump */
# endif
STATIC void
S_init_interp(pTHX)
{
- dVAR;
#ifdef MULTIPLICITY
# define PERLVAR(prefix,var,type)
# define PERLVARA(prefix,var,n,type)
STATIC void
S_init_main_stash(pTHX)
{
- dVAR;
GV *gv;
PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
GvMULTI_on(PL_replgv);
(void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
#ifdef PERL_DONT_CREATE_GVSV
- gv_SVadd(PL_errgv);
+ (void)gv_SVadd(PL_errgv);
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
CLEAR_ERRSV();
{
int fdscript = -1;
PerlIO *rsfp = NULL;
- dVAR;
Stat_t tmpstatbuf;
+ int fd;
PERL_ARGS_ASSERT_OPEN_SCRIPT;
PL_origfilename = savepvs("-e");
}
else {
+ const char *s;
+ UV uv;
/* 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) && isDIGIT(scriptname[8]) ) {
- const char *s = scriptname + 8;
- fdscript = atoi(s);
- while (isDIGIT(*s))
- s++;
+ if (strnEQ(scriptname, "/dev/fd/", 8)
+ && isDIGIT(scriptname[8])
+ && grok_atoUV(scriptname + 8, &uv, &s)
+ && uv <= PERL_INT_MAX
+ ) {
+ fdscript = (int)uv;
if (*s) {
/* PSz 18 Feb 04
* Tell apart "normal" usage of fdscript, e.g.
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);
if (tmpfd > -1) {
scriptname = tmpname;
close(tmpfd);
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
}
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- /* ensure close-on-exec */
- fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+ 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 (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
- && S_ISDIR(tmpstatbuf.st_mode))
+ if (fd < 0 ||
+ (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+ && S_ISDIR(tmpstatbuf.st_mode)))
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop),
Strerror(EISDIR));
if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
dVAR;
-
- PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
- if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
- ||
- (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
- )
+ int fd = PerlIO_fileno(rsfp);
+ 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 == statbuf.st_uid && statbuf.st_mode & S_ISUID)
+ ||
+ (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\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
STATIC void
S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
{
- dVAR;
const char *s;
const char *s2;
{
/* no need to do anything here any more if we don't
* do tainting. */
-#if !NO_TAINT_SUPPORT
- dVAR;
+#ifndef NO_TAINT_SUPPORT
const Uid_t my_uid = PerlProc_getuid();
const Uid_t my_euid = PerlProc_geteuid();
const Gid_t my_gid = PerlProc_getgid();
const Gid_t my_egid = PerlProc_getegid();
+ PERL_UNUSED_CONTEXT;
+
/* Should not happen: */
CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
* if -T are the first chars together; otherwise one gets
* "Too late" message. */
if ( argc > 1 && argv[1][0] == '-'
- && (argv[1][1] == 't' || argv[1][1] == 'T') )
+ && isALPHA_FOLD_EQ(argv[1][1], 't'))
return 1;
return 0;
}
STATIC void
S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
{
- dVAR;
char string[3] = "-x";
const char *message = "program input from stdin";
+ PERL_UNUSED_CONTEXT;
if (flag) {
string[1] = flag;
message = string;
void
Perl_init_debugger(pTHX)
{
- dVAR;
HV * const ostash = PL_curstash;
+ MAGIC *mg;
PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsingle))
sv_setiv(PL_DBsingle, 0);
+ mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SINGLE;
+ SvSETMAGIC(PL_DBsingle);
+
PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBtrace))
sv_setiv(PL_DBtrace, 0);
+ mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_TRACE;
+ SvSETMAGIC(PL_DBtrace);
+
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsignal))
sv_setiv(PL_DBsignal, 0);
+ mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SIGNAL;
+ SvSETMAGIC(PL_DBsignal);
+
SvREFCNT_dec(PL_curstash);
PL_curstash = ostash;
}
void
Perl_init_stacks(pTHX)
{
- dVAR;
+ 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
STATIC void
S_nuke_stacks(pTHX)
{
- dVAR;
while (PL_curstackinfo->si_next)
PL_curstackinfo = PL_curstackinfo->si_next;
while (PL_curstackinfo) {
STATIC void
S_init_predump_symbols(pTHX)
{
- dVAR;
GV *tmpgv;
IO *io;
void
Perl_init_argv_symbols(pTHX_ int argc, char **argv)
{
- dVAR;
-
PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
argc--,argv++; /* skip name of script */
STATIC void
S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
GV* tmpgv;
PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
}
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 */
STATIC void
S_init_perllib(pTHX)
{
- dVAR;
#ifndef VMS
const char *perl5lib = NULL;
#endif
*/
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 */
#ifdef SITELIB_EXP
# if defined(WIN32)
/* this picks up sitearch as well */
- s = win32_get_sitelib(PERL_FS_VERSION, &len);
+ s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
/* this picks up vendorarch as well */
- s = win32_get_vendorlib(PERL_FS_VERSION, &len);
+ s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
#endif
#if defined(WIN32)
- s = win32_get_privlib(PERL_FS_VERSION, &len);
+ s = PerlEnv_lib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
#else
*/
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 */
}
STATIC SV *
S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
{
- dVAR;
Stat_t tmpstatbuf;
PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
STATIC void
S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
{
- dVAR;
#ifndef PERL_IS_MINIPERL
const U8 using_sub_dirs
= (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
#ifdef PERL_IS_MINIPERL
const Size_t extra = 0;
#else
- Size_t extra = av_len(av) + 1;
+ Size_t extra = av_tindex(av) + 1;
#endif
av_unshift(inc, extra + push_basedir);
if (push_basedir)
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
- dVAR;
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;
PERL_ARGS_ASSERT_CALL_LIST;
- while (av_len(paramList) >= 0) {
+ while (av_tindex(paramList) >= 0) {
cv = MUTABLE_CV(av_shift(paramList));
if (PL_savebegin) {
if (paramList == PL_beginav) {
Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
}
} else {
- if (!PL_madskills)
- SAVEFREESV(cv);
+ SAVEFREESV(cv);
}
JMPENV_PUSH(ret);
switch (ret) {
case 0:
-#ifdef PERL_MAD
- if (PL_madskills)
- PL_madskills |= 16384;
-#endif
CALL_LIST_BODY(cv);
-#ifdef PERL_MAD
- if (PL_madskills)
- PL_madskills &= ~16384;
-#endif
atsv = ERRSV;
(void)SvPV_const(atsv, len);
if (len) {
break;
case 1:
STATUS_ALL_FAILURE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 2:
/* my_exit() was called */
while (PL_scopestack_ix > oldscope)
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_curcop = &PL_compiling;
void
Perl_my_exit(pTHX_ U32 status)
{
- dVAR;
if (PL_exit_flags & PERL_EXIT_ABORT) {
abort();
}
void
Perl_my_failure_exit(pTHX)
{
- dVAR;
#ifdef VMS
/* We have been called to fall on our sword. The desired exit code
* should be already set in STATUS_UNIX, but could be shifted over
STATIC void
S_my_exit_jump(pTHX)
{
- dVAR;
-
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_e_script = NULL;
}
POPSTACK_TO(PL_mainstack);
- dounwind(-1);
+ if (cxstack_ix >= 0) {
+ dounwind(-1);
+ cx_popblock(cxstack);
+ }
LEAVE_SCOPE(0);
JMPENV_JUMP(2);
static I32
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- dVAR;
const char * const p = SvPVX_const(PL_e_script);
const char *nl = strchr(p, '\n');
return 1;
}
+/* removes boilerplate code at the end of each boot_Module xsub */
+void
+Perl_xs_boot_epilog(pTHX_ const I32 ax)
+{
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ XSRETURN_YES;
+}
+
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/