#include "perl.h"
#include "patchlevel.h" /* for local_patches */
#include "XSUB.h"
+#include "charclass_invlists.h"
#ifdef NETWARE
#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>
}
void
-Perl_sys_term()
+Perl_sys_term(void)
{
dVAR;
if (!PL_veto_cleanup) {
#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);
STATUS_ALL_SUCCESS;
init_i18nl10n(1);
- SET_NUMERIC_STANDARD();
#if defined(LOCAL_PATCH_COUNT)
PL_localpatches = local_patches; /* For possible -v */
HvSHAREKEYS_off(PL_strtab); /* mandatory */
hv_ksplit(PL_strtab, 512);
-#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
- _dyld_lookup_and_bind
- ("__environ", (unsigned long *) &environ_pointer, NULL);
-#endif /* environ */
+ Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
#ifndef PERL_MICRO
# ifdef USE_ENVIRON_ARRAY
/* 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_PSXSPC] = _new_invlist_C_array(XPosixSpace_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);
+
ENTER;
}
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
{
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 {
+ i = grok_atou(s, NULL);
+ }
#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;
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);
/* 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
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_DBsingle_iv = 0;
+ PL_DBtrace_iv = 0;
+ PL_DBsignal_iv = 0;
PL_DBcv = 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_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);
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_InBitmap = 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;
}
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);
PL_debug &= ~ DEBUG_m_FLAG;
}
while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
- safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+ safesysfree(PERL_MEMORY_DEBUG_HEADER_SIZE + (char *)(aTHXx->Imemory_debug_header.next));
PL_debug = old_debug;
}
}
{
# 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;
}
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;
++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
{
const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- if (s && (atoi(s) == 1)) {
+ if (s && (grok_atou(s, NULL) == 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");
}
}
* --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]));
init_ids();
assert (!TAINT_get);
TAINT;
- S_set_caret_X(aTHX);
+ set_caret_X();
TAINT_NOT;
init_postdump_symbols(argc,argv,env);
return 0;
break;
case 1:
STATUS_ALL_FAILURE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 2:
/* my_exit() was called */
while (PL_scopestack_ix > oldscope)
# ifdef NO_MATHOMS
" NO_MATHOMS"
# endif
+# ifdef NO_HASH_SEED
+ " NO_HASH_SEED"
+# endif
+# ifdef NO_TAINT_SUPPORT
+ " NO_TAINT_SUPPORT"
+# endif
+# ifdef PERL_BOOL_AS_CHAR
+ " PERL_BOOL_AS_CHAR"
+# 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
+#if defined(SILENT_NO_TAINT_SUPPORT)
/* silently ignore */
-#elif NO_TAINT_SUPPORT
- Perl_croak("This perl was compiled without 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
CHECK_MALLOC_TOO_LATE_FOR('t');
s++;
goto reswitch;
case 'T':
-#if SILENT_NO_TAINT_SUPPORT
+#if defined(SILENT_NO_TAINT_SUPPORT)
/* silently ignore */
-#elif NO_TAINT_SUPPORT
- Perl_croak("This perl was compiled without 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
CHECK_MALLOC_TOO_LATE_FOR('T');
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);
}
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
- Perl_croak("This perl was compiled without 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
CHECK_MALLOC_TOO_LATE_FOR('T');
}
}
if (*d == 't') {
-#if SILENT_NO_TAINT_SUPPORT
+#if defined(SILENT_NO_TAINT_SUPPORT)
/* silently ignore */
-#elif NO_TAINT_SUPPORT
- Perl_croak("This perl was compiled without 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( !TAINTING_get) {
/* 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)
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 }",
- 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);
}
}
}
-#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);
- if(linestr_sv)
- SvREFCNT_dec(linestr_sv);
+ SvREFCNT_dec(linestr_sv);
PL_subname = newSVpvs("main");
#ifdef MYMALLOC
{
const char *s;
- if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
- dump_mstats("after compilation:");
+ if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && grok_atou(s, NULL) >= 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);
=for apidoc p||get_sv
Returns the SV of the specified Perl scalar. C<flags> are passed to
-C<gv_fetchpv>. If C<GV_ADD> is set and the
+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.
Returns the AV of the specified Perl global or package array with the given
name (so it won't work on lexical variables). C<flags> are passed
-to C<gv_fetchpv>. If C<GV_ADD> is set and the
+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.
=for apidoc p||get_hv
Returns the HV of the specified Perl hash. C<flags> are passed to
-C<gv_fetchpv>. If C<GV_ADD> is set and the
+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.
=for apidoc p||get_cvn_flags
Returns the CV of the specified Perl subroutine. C<flags> are passed to
-C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
+C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
exist then it will be declared (which has the same effect as saying
C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
then NULL is returned.
=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 L<perlcall>.
+with C<argv> (a 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;
/* 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;
+ METHOP method_op;
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)) {
+ Zero(&method_op, 1, METHOP);
+ method_op.op_next = (OP*)&myop;
+ PL_op = (OP*)&method_op;
+ if ( flags & G_METHOD_NAMED ) {
+ 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 {
+ 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)) {
break;
case 1:
STATUS_ALL_FAILURE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 2:
/* my_exit() was called */
SET_CURSTASH(PL_defstash);
/*
=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>.
+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>.
=cut
*/
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 */
break;
case 1:
STATUS_ALL_FAILURE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 2:
/* my_exit() was called */
SET_CURSTASH(PL_defstash);
/*
=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;
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;
}
" 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;
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);
}
}
else if (isDIGIT(**s)) {
- i = atoi(*s);
+ const char* e;
+ i = grok_atou(*s, &e);
+ if (e)
+ *s = e;
for (; isWORDCHAR(**s); (*s)++) ;
}
else if (givehelp) {
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':
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
- Perl_croak("This perl was compiled without 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 (!TAINTING_get)
S_minus_v(pTHX)
{
PerlIO * PIO_stdout;
- if (!sv_derived_from(PL_patchlevel, "version"))
- upg_version(PL_patchlevel, TRUE);
-#if !defined(DGUX)
{
- 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)
", version " STRINGIFY(PERL_VERSION)
", subversion " STRINGIFY(PERL_SUBVERSION)
- " (%"SVf") built for " ARCHNAME, level
+ " (%"SVf") built for " ARCHNAME, SVfARG(level)
);
- SvREFCNT_dec(level);
+ SvREFCNT_dec_NN(level);
}
-#else /* DGUX */
- PIO_stdout = PerlIO_stdout();
-/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
- PerlIO_printf(PIO_stdout,
- Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
- SVfARG(vstringify(PL_patchlevel))));
- PerlIO_printf(PIO_stdout,
- Perl_form(aTHX_ " built under %s at %s %s\n",
- OSNAME, __DATE__, __TIME__));
- PerlIO_printf(PIO_stdout,
- Perl_form(aTHX_ " OS Specific Release: %s\n",
- OSVERS));
-#endif /* !DGUX */
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
PerlIO_printf(PIO_stdout,
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2012, Larry Wall\n");
+ "\n\nCopyright 1987-2014, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef __VOS__
PerlIO_printf(PIO_stdout,
- "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
+ "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
#endif
#ifdef POSIX_BC
PerlIO_printf(PIO_stdout,
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)
# 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
S_init_main_stash(pTHX)
{
- dVAR;
GV *gv;
PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
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;
+ int fd;
PERL_ARGS_ASSERT_OPEN_SCRIPT;
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
const char *s = scriptname + 8;
- fdscript = atoi(s);
- while (isDIGIT(*s))
- s++;
+ const char* e;
+ fdscript = grok_atou(s, &e);
+ s = e;
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(0600);
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));
}
+ fd = PerlIO_fileno(rsfp);
#if defined(HAS_FCNTL) && defined(F_SETFD)
- /* ensure close-on-exec */
- fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+ if (fd >= 0) {
+ /* ensure close-on-exec */
+ if (fcntl(fd, F_SETFD, 1) < 0) {
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop), Strerror(errno));
+ }
+ }
#endif
+
+ 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));
+
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;
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);
+ if (fd < 0) {
+ Perl_croak(aTHX_ "Illegal suidscript");
+ } else {
+ if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */
+ Perl_croak(aTHX_ "Illegal suidscript");
+ }
+ }
+ 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)
+ )
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;
- const UV my_uid = PerlProc_getuid();
- const UV my_euid = PerlProc_geteuid();
- const UV my_gid = PerlProc_getgid();
- const UV my_egid = PerlProc_getegid();
+#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));
* 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
* 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);
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);
+ 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;
}
#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
Perl_init_stacks(pTHX)
{
- dVAR;
/* 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(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
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 */
}
}
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_ int argc, char **argv, char **env)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
GV* tmpgv;
PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
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);
STATIC void
S_init_perllib(pTHX)
{
- dVAR;
#ifndef VMS
const char *perl5lib = NULL;
#endif
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;
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
{
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
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
/* 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_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;
CV *cv;
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)
void
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;
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
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();
}
STATIC void
S_my_exit_jump(pTHX)
{
- dVAR;
-
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_e_script = NULL;
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');
https://perl5.git.perl.org / perl5.git / blobdiff