#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>
#endif
-#ifdef __BEOS__
-# define HZ 1000000
-#endif
-
#ifndef HZ
# ifdef CLK_TCK
# define HZ CLK_TCK
#endif
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
+#ifdef PERL_TRACE_OPS
+ Zero(PL_op_exec_cnt, OP_max+2, UV);
+#endif
+
init_constants();
SvREADONLY_on(&PL_sv_placeholder);
- SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
+ SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
PL_sighandlerp = (Sighandler_t) Perl_sighandler;
#ifdef PERL_USES_PL_PIDSTATUS
#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) {
+ Perl_get_hash_seed(aTHX_ PL_hash_seed);
+ 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.
HvSHAREKEYS_off(PL_strtab); /* mandatory */
hv_ksplit(PL_strtab, 512);
+ 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);
/* Use sysconf(_SC_CLK_TCK) if available, if not
* available or if the sysconf() fails, use the HZ.
- * BeOS has those, but returns the wrong value.
* The HZ if not originally defined has been by now
* been defined as CLK_TCK, if available. */
-#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
PL_clocktick = sysconf(_SC_CLK_TCK);
if (PL_clocktick <= 0)
#endif
if (returned_errno || *buffer) {
Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
" %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
- returned_errno, strerror(returned_errno));
+ returned_errno, Strerror(returned_errno));
}
}
#endif
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
pid_t child;
#endif
+ int i;
PERL_ARGS_ASSERT_PERL_DESTRUCT;
#ifndef MULTIPLICITY
{
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
}
}
/* Need to flush since END blocks can produce output */
my_fflush_all();
+#ifdef PERL_TRACE_OPS
+ /* If we traced all Perl OP usage, report and clean up */
+ 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;
+ }
+ /* 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");
+#endif
+
+
if (PL_threadhook(aTHX)) {
/* Threads hook has vetoed further cleanup */
PL_veto_cleanup = TRUE;
/* 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;
PerlIO_destruct(aTHX);
- if (PL_sv_objcount) {
- /*
- * Try to destruct global references. We do this first so that the
- * destructors and destructees still exist. Some sv's might remain.
- * Non-referenced objects are on their own.
- */
- sv_clean_objs();
- PL_sv_objcount = 0;
- }
+ /*
+ * Try to destruct global references. We do this first so that the
+ * destructors and destructees still exist. Some sv's might remain.
+ * Non-referenced objects are on their own.
+ */
+ sv_clean_objs();
/* unhook hooks which will soon be, or use, destroyed data */
SvREFCNT_dec(PL_warnhook);
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
ary[i] = &PL_sv_undef;
}
}
- Safefree(PL_stashpad);
#endif
PL_minus_F = FALSE;
PL_doswitches = FALSE;
PL_dowarn = G_WARN_OFF;
+#ifdef PERL_SAWAMPERSAND
PL_sawampersand = 0; /* must save all match strings */
+#endif
PL_unsafe = FALSE;
Safefree(PL_inplace);
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;
PL_numeric_radix_sv = NULL;
#endif
- /* clear utf8 character classes */
- SvREFCNT_dec(PL_utf8_alnum);
- SvREFCNT_dec(PL_utf8_alpha);
- SvREFCNT_dec(PL_utf8_blank);
- SvREFCNT_dec(PL_utf8_space);
- SvREFCNT_dec(PL_utf8_graph);
- SvREFCNT_dec(PL_utf8_digit);
- SvREFCNT_dec(PL_utf8_upper);
- SvREFCNT_dec(PL_utf8_lower);
- SvREFCNT_dec(PL_utf8_print);
- SvREFCNT_dec(PL_utf8_punct);
- SvREFCNT_dec(PL_utf8_xdigit);
+ /* clear character classes */
+ for (i = 0; i < POSIX_SWASH_COUNT; i++) {
+ SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
+ PL_utf8_swash_ptrs[i] = NULL;
+ }
SvREFCNT_dec(PL_utf8_mark);
SvREFCNT_dec(PL_utf8_toupper);
SvREFCNT_dec(PL_utf8_totitle);
SvREFCNT_dec(PL_utf8_idstart);
SvREFCNT_dec(PL_utf8_idcont);
SvREFCNT_dec(PL_utf8_foldclosures);
- PL_utf8_alnum = NULL;
- PL_utf8_alpha = NULL;
- PL_utf8_blank = NULL;
- PL_utf8_space = NULL;
- PL_utf8_graph = NULL;
- PL_utf8_digit = NULL;
- PL_utf8_upper = NULL;
- PL_utf8_lower = NULL;
- PL_utf8_print = NULL;
- PL_utf8_punct = NULL;
- PL_utf8_xdigit = NULL;
+ 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;
+
+ SvREFCNT_dec(PL_L1Posix_ptrs[i]);
+ PL_L1Posix_ptrs[i] = NULL;
+
+ SvREFCNT_dec(PL_XPosix_ptrs[i]);
+ PL_XPosix_ptrs[i] = NULL;
+ }
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
while (sv_clean_all() > 2)
;
+#ifdef USE_ITHREADS
+ Safefree(PL_stashpad); /* must come after sv_clean_all */
+#endif
+
AvREAL_off(PL_fdpid); /* no surviving entries */
SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
PL_fdpid = NULL;
sys_intern_clear();
#endif
+ /* constant strings */
+ for (i = 0; i < SV_CONSTS_COUNT; i++) {
+ SvREFCNT_dec(PL_sv_consts[i]);
+ PL_sv_consts[i] = NULL;
+ }
+
/* Destruct the global string table. */
{
/* Yell and reset the HeVAL() slots that are still holding refcounts,
Safefree(PL_origfilename);
PL_origfilename = NULL;
Safefree(PL_reg_curpm);
- Safefree(PL_reg_poscache);
free_tied_hv_pool();
Safefree(PL_op_mask);
Safefree(PL_psig_name);
Safefree(psig_save);
}
nuke_stacks();
- PL_tainting = FALSE;
- PL_taint_warn = FALSE;
+ TAINTING_set(FALSE);
+ TAINT_WARN_set(FALSE);
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
PL_debug = 0;
{
# ifdef NETWARE
void *host = nw_internal_host;
-# else
- void *host = w32_internal_host;
-# endif
PerlMem_free(aTHXx);
-# ifdef NETWARE
nw_delete_internal_host(host);
# else
+ void *host = w32_internal_host;
+ PerlMem_free(aTHXx);
win32_delete_internal_host(host);
# endif
}
perl_fini(void)
{
dVAR;
- if (PL_curinterp && !PL_veto_cleanup)
+ if (
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+ my_vars &&
+#endif
+ PL_curinterp && !PL_veto_cleanup)
FREE_THREAD_KEY;
}
++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
#ifndef MULTIPLICITY
PERL_UNUSED_ARG(my_perl);
#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_rehash_seed (and presumably also PL_rehash_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. */
- if (!PL_rehash_seed_set)
- PL_rehash_seed = get_hash_seed();
+#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
{
- const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
-
- if (s && (atoi(s) == 1))
- PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
+ 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;
+ 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++);
+ }
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
+ PL_HASH_RAND_BITS_ENABLED,
+ PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
+#endif
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
-
PL_origargc = argc;
PL_origargv = argv;
PL_do_undump = FALSE;
cxstack_ix = -1; /* start label stack again */
init_ids();
- assert (!PL_tainted);
+ assert (!TAINT_get);
TAINT;
- S_set_caret_X(aTHX);
+ set_caret_X();
TAINT_NOT;
init_postdump_symbols(argc,argv,env);
return 0;
#endif
const int entries = 3 + local_patch_count;
int i;
- static char non_bincompat_options[] =
+ static const char non_bincompat_options[] =
# ifdef DEBUGGING
" DEBUGGING"
# endif
# ifdef NO_MATHOMS
" NO_MATHOMS"
# endif
+# ifdef NO_HASH_SEED
+ " NO_HASH_SEED"
+# endif
+# ifdef NO_TAINT_SUPPORT
+ " NO_TAINT_SUPPORT"
+# endif
# ifdef PERL_DISABLE_PMC
" PERL_DISABLE_PMC"
# endif
# ifdef PERL_EXTERNAL_GLOB
" PERL_EXTERNAL_GLOB"
# endif
+# ifdef PERL_HASH_FUNC_SIPHASH
+ " PERL_HASH_FUNC_SIPHASH"
+# endif
+# ifdef PERL_HASH_FUNC_SDBM
+ " PERL_HASH_FUNC_SDBM"
+# endif
+# ifdef PERL_HASH_FUNC_DJB2
+ " PERL_HASH_FUNC_DJB2"
+# endif
+# ifdef PERL_HASH_FUNC_SUPERFAST
+ " PERL_HASH_FUNC_SUPERFAST"
+# endif
+# ifdef PERL_HASH_FUNC_MURMUR3
+ " PERL_HASH_FUNC_MURMUR3"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
+ " PERL_HASH_FUNC_ONE_AT_A_TIME"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
+ " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
+ " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
+# endif
# ifdef PERL_IS_MINIPERL
" PERL_IS_MINIPERL"
# 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 PERL_PERTURB_KEYS_DISABLED
+ " PERL_PERTURB_KEYS_DISABLED"
+# endif
+# ifdef PERL_PERTURB_KEYS_RANDOM
+ " PERL_PERTURB_KEYS_RANDOM"
+# endif
# ifdef PERL_PRESERVE_IVUV
" PERL_PRESERVE_IVUV"
# 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
break;
case 't':
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
CHECK_MALLOC_TOO_LATE_FOR('t');
- if( !PL_tainting ) {
- PL_taint_warn = TRUE;
- PL_tainting = TRUE;
+ if( !TAINTING_get ) {
+ TAINT_WARN_set(TRUE);
+ TAINTING_set(TRUE);
}
+#endif
s++;
goto reswitch;
case 'T':
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
CHECK_MALLOC_TOO_LATE_FOR('T');
- PL_tainting = TRUE;
- PL_taint_warn = FALSE;
+ TAINTING_set(TRUE);
+ TAINT_WARN_set(FALSE);
+#endif
s++;
goto reswitch;
if (
#ifndef SECURE_INTERNAL_GETENV
- !PL_tainting &&
+ !TAINTING_get &&
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
CHECK_MALLOC_TOO_LATE_FOR('T');
- PL_tainting = TRUE;
- PL_taint_warn = FALSE;
+ TAINTING_set(TRUE);
+ TAINT_WARN_set(FALSE);
+#endif
}
else {
char *popt_copy = NULL;
}
}
if (*d == 't') {
- if( !PL_tainting ) {
- PL_taint_warn = TRUE;
- PL_tainting = TRUE;
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
+ if( !TAINTING_get) {
+ TAINT_WARN_set(TRUE);
+ TAINTING_set(TRUE);
}
+#endif
} else {
moreswitches(d);
}
/* Set $^X early so that it can be used for relocatable paths in @INC */
/* and for SITELIB_EXP in USE_SITECUSTOMIZE */
- assert (!PL_tainted);
+ assert (!TAINT_get);
TAINT;
- S_set_caret_X(aTHX);
+ set_caret_X();
TAINT_NOT;
#if defined(USE_SITECUSTOMIZE)
SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
if (inc0) {
+ /* if lib/buildcustomize.pl exists, it should not fail. If it does,
+ 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} && do q%c%"SVf"/buildcustomize.pl%c }",
+ "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));
}
scriptname = "-";
}
- assert (!PL_tainted);
+ assert (!TAINT_get);
init_perllib();
{
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
#ifndef PERL_MICRO
-#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
init_os_extras();
#endif
#endif
#ifdef PERL_MAD
{
const char *s;
- if (!PL_tainting &&
+ if (!TAINTING_get &&
(s = PerlEnv_getenv("PERL_XMLDUMP"))) {
PL_madskills = 1;
PL_minus_c = 1;
#endif
lex_start(linestr_sv, rsfp, lex_start_flags);
- if(linestr_sv)
- SvREFCNT_dec(linestr_sv);
+ SvREFCNT_dec(linestr_sv);
PL_subname = newSVpvs("main");
*/
I32
-Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
+Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
/* See G_* flags in cop.h */
/* null terminated arg list */
/* See G_* flags in cop.h */
{
STRLEN len;
+ SV* sv;
PERL_ARGS_ASSERT_CALL_METHOD;
len = strlen(methname);
+ sv = flags & G_METHOD_NAMED
+ ? sv_2mortal(newSVpvn_share(methname, len,0))
+ : newSVpvn_flags(methname, len, SVs_TEMP);
- /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */
- return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD);
+ return call_sv(sv, flags | G_METHOD);
}
/* May be called with any of a CV, a GV, or an SV containing the name. */
{
dVAR; dSP;
LOGOP myop; /* fake syntax tree node */
- UNOP method_op;
+ UNOP method_unop;
+ SVOP method_svop;
I32 oldmark;
VOL I32 retval = 0;
I32 oldscope;
PL_op = (OP*)&myop;
EXTEND(PL_stack_sp, 1);
- *++PL_stack_sp = sv;
+ if (!(flags & G_METHOD_NAMED))
+ *++PL_stack_sp = sv;
oldmark = TOPMARK;
oldscope = PL_scopestack_ix;
&& !(flags & G_NODEBUG))
myop.op_private |= OPpENTERSUB_DB;
- if (flags & G_METHOD) {
- Zero(&method_op, 1, UNOP);
- method_op.op_next = (OP*)&myop;
- 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;
- PL_op = (OP*)&method_op;
+ if (flags & (G_METHOD|G_METHOD_NAMED)) {
+ 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;
+ } 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;
+ }
+ myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
+ myop.op_type = OP_ENTERSUB;
+
}
if (!(flags & G_EVAL)) {
myop.op_flags |= OP_GIMME_REVERSE(flags);
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
- if (PL_reg_state.re_reparsing)
- myop.op_private = OPpEVAL_COPHH;
+
+ if (flags & G_RE_REPARSING)
+ 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 */
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
dVAR;
- dSP;
SV* sv = newSVpv(p, 0);
PERL_ARGS_ASSERT_EVAL_PV;
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
- SPAGAIN;
- sv = POPs;
- PUTBACK;
+ {
+ dSP;
+ sv = POPs;
+ PUTBACK;
+ }
- if (croak_on_error && SvTRUE(ERRSV)) {
- Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
+ /* just check empty string or undef? */
+ if (croak_on_error) {
+ SV * const errsv = ERRSV;
+ if(SvTRUE_NN(errsv))
+ /* replace with croak_sv? */
+ Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
}
return sv;
/* if adding extra options, remember to update DEBUG_MASK */
static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
- for (; isALNUM(**s); (*s)++) {
+ for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
if (d)
i |= 1 << (d - debopts);
}
else if (isDIGIT(**s)) {
i = atoi(*s);
- for (; isALNUM(**s); (*s)++) ;
+ for (; isWORDCHAR(**s); (*s)++) ;
}
else if (givehelp) {
const char *const *p = usage_msgd;
PL_utf8cache = -1;
return s;
case 'F':
+ PL_minus_a = TRUE;
PL_minus_F = TRUE;
+ PL_minus_n = TRUE;
PL_splitstr = ++s;
while (*s && !isSPACE(*s)) ++s;
PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
return s;
case 'a':
PL_minus_a = TRUE;
+ PL_minus_n = TRUE;
s++;
return s;
case 'c':
s++;
/* -dt indicates to the debugger that threads will be used */
- if (*s == 't' && !isALNUM(s[1])) {
+ if (*s == 't' && !isWORDCHAR(s[1])) {
++s;
my_setenv("PERL5DB_THREADED", "1");
}
end = s + strlen(s);
/* We now allow -d:Module=Foo,Bar and -d:-Module */
- while(isALNUM(*s) || *s==':') ++s;
+ while(isWORDCHAR(*s) || *s==':') ++s;
if (*s != '=')
sv_catpvn(sv, start, end - start);
else {
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
- for (s++; isALNUM(*s); s++) ;
+ for (s++; isWORDCHAR(*s); s++) ;
#endif
return s;
}
sv = newSVpvn(use,4);
start = s;
/* We allow -M'Module qw(Foo Bar)' */
- while(isALNUM(*s) || *s==':') {
+ while(isWORDCHAR(*s) || *s==':') {
if( *s++ == ':' ) {
if( *s == ':' )
s++;
return s;
case 't':
case 'T':
- if (!PL_tainting)
+#if SILENT_NO_TAINT_SUPPORT
+ /* silently ignore */
+#elif NO_TAINT_SUPPORT
+ Perl_croak_nocontext("This perl was compiled without taint support. "
+ "Cowardly refusing to run with -t or -T flags");
+#else
+ if (!TAINTING_get)
TOO_LATE_FOR(*s);
+#endif
s++;
return s;
case 'u':
STATIC void
S_minus_v(pTHX)
{
- if (!sv_derived_from(PL_patchlevel, "version"))
- upg_version(PL_patchlevel, TRUE);
-#if !defined(DGUX)
+ PerlIO * PIO_stdout;
{
- 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
-
- if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
- SvREFCNT_dec(level);
- level= num;
- } else {
- Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
- SvREFCNT_dec(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 {
+ level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
+ }
}
- #endif
- PerlIO_printf(PerlIO_stdout(),
+#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)
", version " STRINGIFY(PERL_VERSION)
", subversion " STRINGIFY(PERL_SUBVERSION)
" (%"SVf") built for " ARCHNAME, level
);
- SvREFCNT_dec(level);
+ SvREFCNT_dec_NN(level);
}
-#else /* DGUX */
-/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
- PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
- SVfARG(vstringify(PL_patchlevel))));
- PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ " built under %s at %s %s\n",
- OSNAME, __DATE__, __TIME__));
- PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ " OS Specific Release: %s\n",
- OSVERS));
-#endif /* !DGUX */
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"\n(with %d registered patch%s, "
"see perl -V for more detail)",
LOCAL_PATCH_COUNT,
(LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
- PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2012, Larry Wall\n");
+ PerlIO_printf(PIO_stdout,
+ "\n\nCopyright 1987-2013, Larry Wall\n");
#ifdef MSDOS
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef DJGPP
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
"djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
#endif
#ifdef OS2
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
"Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
#endif
-#ifdef __BEOS__
- PerlIO_printf(PerlIO_stdout(),
- "BeOS port Copyright Tom Spindler, 1997-1999\n");
-#endif
#ifdef OEMVS
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
#endif
#ifdef __VOS__
- PerlIO_printf(PerlIO_stdout(),
- "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
+ PerlIO_printf(PIO_stdout,
+ "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
#endif
#ifdef POSIX_BC
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
#endif
-#ifdef EPOC
- PerlIO_printf(PerlIO_stdout(),
- "EPOC port by Olaf Flebbe, 1999-2002\n");
-#endif
#ifdef UNDER_CE
- PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
- PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
+ PerlIO_printf(PIO_stdout,
+ "WINCE port by Rainer Keuchel, 2001-2002\n"
+ "Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
#ifdef __SYMBIAN32__
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"Symbian port by Nokia, 2004-2005\n");
#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
- PerlIO_printf(PerlIO_stdout(),
+ PerlIO_printf(PIO_stdout,
"\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
# undef PERLVARIC
#endif
- /* As these are inside a structure, PERLVARI isn't capable of initialising
- them */
- PL_reg_oldcurpm = PL_reg_curpm = NULL;
- PL_reg_poscache = PL_reg_starttry = NULL;
}
STATIC void
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
int fdscript = -1;
PerlIO *rsfp = NULL;
dVAR;
+ Stat_t tmpstatbuf;
PERL_ARGS_ASSERT_OPEN_SCRIPT;
/* ensure close-on-exec */
fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
#endif
+
+ if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
+ && S_ISDIR(tmpstatbuf.st_mode))
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop),
+ Strerror(EISDIR));
+
return rsfp;
}
STATIC void
S_validate_suid(pTHX_ PerlIO *rsfp)
{
- const UV my_uid = PerlProc_getuid();
- const UV my_euid = PerlProc_geteuid();
- const UV my_gid = PerlProc_getgid();
- const UV my_egid = PerlProc_getegid();
+ 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_ARGS_ASSERT_VALIDATE_SUID;
STATIC void
S_init_ids(pTHX)
{
+ /* no need to do anything here any more if we don't
+ * do tainting. */
+#if !NO_TAINT_SUPPORT
dVAR;
- const UV my_uid = PerlProc_getuid();
- const UV my_euid = PerlProc_geteuid();
- const UV my_gid = PerlProc_getgid();
- const UV my_egid = PerlProc_getegid();
+ 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();
/* Should not happen: */
CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
- PL_tainting |= (my_uid && (my_euid != my_uid || my_egid != my_gid));
+ TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
+#endif
/* BUG */
/* PSz 27 Feb 04
* Should go by suidscript, not uid!=euid: why disallow
* have to add your own checks somewhere in here. The two most
* known samples of 'implicitness' are Win32 and NetWare, neither
* of which has much of concept of 'uids'. */
- int uid = PerlProc_getuid();
- int euid = PerlProc_geteuid();
- int gid = PerlProc_getgid();
- int egid = PerlProc_getegid();
+ Uid_t uid = PerlProc_getuid();
+ Uid_t euid = PerlProc_geteuid();
+ Gid_t gid = PerlProc_getgid();
+ Gid_t egid = PerlProc_getegid();
(void)envp;
#ifdef VMS
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);
}
void
-Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
+Perl_init_argv_symbols(pTHX_ int argc, char **argv)
{
dVAR;
}
}
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);
}
STATIC void
-S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
+S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
{
dVAR;
GV* tmpgv;
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);
STRLEN len;
#endif
- if (!PL_tainting) {
+ if (!TAINTING_get) {
#ifndef VMS
perl5lib = PerlEnv_getenv("PERL5LIB");
/*
|INCPUSH_CAN_RELOCATE);
#endif
- if (!PL_tainting) {
+ if (!TAINTING_get) {
#ifndef VMS
/*
* It isn't possible to delete an environment variable with
#endif
#endif /* !PERL_IS_MINIPERL */
- if (!PL_tainting)
+ if (!TAINTING_get)
S_incpush(aTHX_ STR_WITH_LEN("."), 0);
}
-#if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
+#if defined(DOSISH) || defined(__SYMBIAN32__)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
PERL_ARGS_ASSERT_MAYBERELOCATE;
assert(len > 0);
- if (len) {
- /* I am not convinced that this is valid when PERLLIB_MANGLE is
- defined to so something (in os2/os2.c), but the code has been
- this way, ignoring any possible changed of length, since
- 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
- it be. */
- libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
- } else {
- libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0);
- }
+ /* I am not convinced that this is valid when PERLLIB_MANGLE is
+ defined to so something (in os2/os2.c), but the code has been
+ this way, ignoring any possible changed of length, since
+ 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
+ it be. */
+ libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
#ifdef VMS
{
SvREFCNT_dec(libdir);
/* And this is the new libdir. */
libdir = tempsv;
- if (PL_tainting &&
+ if (TAINTING_get &&
(PerlProc_getuid() != PerlProc_geteuid() ||
PerlProc_getgid() != PerlProc_getegid())) {
/* Need to taint relocated paths if running set ID */
/* 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();
}
https://perl5.git.perl.org / perl5.git / blobdiff