#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) {
STATUS_ALL_SUCCESS;
init_i18nl10n(1);
- SET_NUMERIC_STANDARD();
#if defined(LOCAL_PATCH_COUNT)
PL_localpatches = local_patches; /* For possible -v */
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_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;
}
{
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
}
}
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);
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
Safefree(PL_inplace);
PL_inplace = NULL;
SvREFCNT_dec(PL_patchlevel);
- SvREFCNT_dec(PL_apiversion);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
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;
}
"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;
++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);
* --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_TAINT_SUPPORT
" NO_TAINT_SUPPORT"
# endif
+# ifdef PERL_BOOL_AS_CHAR
+ " PERL_BOOL_AS_CHAR"
+# endif
# ifdef PERL_DISABLE_PMC
" PERL_DISABLE_PMC"
# endif
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);
}
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
/* 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)
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:");
+ 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;
{
dVAR; dSP;
LOGOP myop; /* fake syntax tree node */
- UNOP method_unop;
- SVOP method_svop;
+ METHOP method_op;
I32 oldmark;
VOL I32 retval = 0;
I32 oldscope;
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)) {
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
*/
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) {
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
S_minus_v(pTHX)
{
PerlIO * PIO_stdout;
- if (!sv_derived_from(PL_patchlevel, "version"))
- upg_version(PL_patchlevel, TRUE);
{
- SV* level= vstringify(PL_patchlevel);
+ const char * const level_str = "v" PERL_VERSION_STRING;
+ const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
#ifdef PERL_PATCHNUM
+ SV* level;
# ifdef PERL_GIT_UNCOMMITTED_CHANGES
- SV *num = newSVpvs(PERL_PATCHNUM "*");
+ static const char num [] = PERL_PATCHNUM "*";
# else
- SV *num = newSVpvs(PERL_PATCHNUM);
+ static const char num [] = PERL_PATCHNUM;
# endif
{
- STRLEN level_len, num_len;
- char * level_str, * num_str;
- num_str = SvPV(num, num_len);
- level_str = SvPV(level, level_len);
- if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) {
- SvREFCNT_dec(level);
- level= num;
+ const STRLEN num_len = sizeof(num)-1;
+ /* A very advanced compiler would fold away the strnEQ
+ and this whole conditional, but most (all?) won't do it.
+ SV level could also be replaced by with preprocessor
+ catenation.
+ */
+ if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
+ /* per 46807d8e80, PERL_PATCHNUM is outside of the control
+ of the interp so it might contain format characters
+ */
+ level = newSVpvn(num, num_len);
} else {
- Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
- SvREFCNT_dec(num);
+ level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
}
}
- #endif
+#else
+ SV* level = newSVpvn(level_str, level_len);
+#endif /* #ifdef PERL_PATCHNUM */
PIO_stdout = PerlIO_stdout();
PerlIO_printf(PIO_stdout,
"\nThis is perl " STRINGIFY(PERL_REVISION)
", 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);
}
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2013, 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");
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());
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 (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);
+ 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;
+#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);
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;
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 %u", status);
+ Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status);
PL_exit_flags &= ~PERL_EXIT_ABORT;
}
switch (status) {
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
}
if (PL_exit_flags & PERL_EXIT_WARN) {
PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
- Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue);
+ 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');
return 1;
}
+/* removes boilerplate code at the end of each boot_Module xsub */
+void
+Perl_xs_boot_epilog(pTHX_ const U32 ax)
+{
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ XSRETURN_YES;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff