*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
* 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
- * by Larry Wall and others
+ * 2013, 2014, 2015, 2016 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#include "perl.h"
#include "patchlevel.h" /* for local_patches */
#include "XSUB.h"
-#include "charclass_invlists.h"
#ifdef NETWARE
#include "nwutil.h"
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) {
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);
+ PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist);
+ PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
+ PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
+ PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
ENTER;
}
{
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
if (s) {
- const int i = atoi(s);
+ int i;
+ if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
+ i = -1;
+ } else {
+ UV uv;
+ if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
+ i = (int)uv;
+ else
+ i = 0;
+ }
#ifdef DEBUGGING
if (destruct_level < i) destruct_level = i;
#endif
assert(PL_scopestack_ix == 0);
/* Need to flush since END blocks can produce output */
+ /* flush stdout separately, since we can identify it */
+#ifdef USE_PERLIO
+ {
+ PerlIO *stdo = PerlIO_stdout();
+ if (*stdo && PerlIO_flush(stdo)) {
+ PerlIO_restore_errno(stdo);
+ PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s",
+ Strerror(errno));
+ if (!STATUS_UNIX)
+ STATUS_ALL_FAILURE;
+ }
+ }
+#endif
my_fflush_all();
#ifdef PERL_TRACE_OPS
Safefree(PL_inplace);
PL_inplace = NULL;
SvREFCNT_dec(PL_patchlevel);
- SvREFCNT_dec(PL_apiversion);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
+ PL_DBsingle_iv = 0;
+ PL_DBtrace_iv = 0;
+ PL_DBsignal_iv = 0;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
SvREFCNT_dec(PL_utf8_foldable);
SvREFCNT_dec(PL_utf8_foldclosures);
SvREFCNT_dec(PL_AboveLatin1);
+ SvREFCNT_dec(PL_InBitmap);
SvREFCNT_dec(PL_UpperLatin1);
SvREFCNT_dec(PL_Latin1);
SvREFCNT_dec(PL_NonL1NonFinalFold);
SvREFCNT_dec(PL_HasMultiCharFold);
+#ifdef USE_LOCALE_CTYPE
+ SvREFCNT_dec(PL_warn_locale);
+#endif
PL_utf8_mark = NULL;
PL_utf8_toupper = NULL;
PL_utf8_totitle = NULL;
PL_utf8_idcont = NULL;
PL_utf8_foldclosures = NULL;
PL_AboveLatin1 = NULL;
+ PL_InBitmap = NULL;
PL_HasMultiCharFold = NULL;
+#ifdef USE_LOCALE_CTYPE
+ PL_warn_locale = NULL;
+#endif
PL_Latin1 = NULL;
PL_NonL1NonFinalFold = NULL;
PL_UpperLatin1 = NULL;
SvREFCNT_dec(PL_XPosix_ptrs[i]);
PL_XPosix_ptrs[i] = NULL;
}
+ PL_GCB_invlist = NULL;
+ PL_LB_invlist = NULL;
+ PL_SB_invlist = NULL;
+ PL_WB_invlist = NULL;
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
TAINTING_set(FALSE);
TAINT_WARN_set(FALSE);
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
- PL_debug = 0;
DEBUG_P(debprofdump());
+ PL_debug = 0;
+
#ifdef USE_REENTRANT_API
Perl_reentrant_free(aTHX);
#endif
+ /* These all point to HVs that are about to be blown away.
+ Code in core and on CPAN assumes that if the interpreter is re-started
+ that they will be cleanly NULL or pointing to a valid HV. */
+ PL_custom_op_names = NULL;
+ PL_custom_op_descs = NULL;
+ PL_custom_ops = NULL;
+
sv_free_arenas();
while (PL_regmatch_slab) {
"free this thread's memory\n");
PL_debug &= ~ DEBUG_m_FLAG;
}
- while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
- safesysfree(PERL_MEMORY_DEBUG_HEADER_SIZE + (char *)(aTHXx->Imemory_debug_header.next));
+ while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
+ char * next = (char *)(aTHXx->Imemory_debug_header.next);
+ Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
+ safesysfree(ptr);
+ }
PL_debug = old_debug;
}
}
void
Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
{
- dVAR;
Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
PL_exitlist[PL_exitlistlen].fn = fn;
PL_exitlist[PL_exitlistlen].ptr = ptr;
{
const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- if (s && (atoi(s) == 1)) {
- unsigned char *seed= PERL_HASH_SEED;
- unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
+ if (s && strEQ(s, "1")) {
+ const unsigned char *seed= PERL_HASH_SEED;
+ const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
while (seed < seed_end) {
PerlIO_printf(Perl_debug_log, "%02x", *seed++);
}
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
+
+#ifdef __amigaos4__
+ {
+ struct NameTranslationInfo nti;
+ __translate_amiga_to_unix_path_name(&argv[0],&nti);
+ }
+#endif
+
PL_origargc = argc;
PL_origargv = argv;
# ifdef PERL_BOOL_AS_CHAR
" PERL_BOOL_AS_CHAR"
# endif
+# ifdef PERL_COPY_ON_WRITE
+ " PERL_COPY_ON_WRITE"
+# endif
# ifdef PERL_DISABLE_PMC
" PERL_DISABLE_PMC"
# endif
# ifdef PERL_MEM_LOG_NOIMPL
" PERL_MEM_LOG_NOIMPL"
# endif
-# ifdef PERL_NEW_COPY_ON_WRITE
- " PERL_NEW_COPY_ON_WRITE"
-# endif
# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
" PERL_PERTURB_KEYS_DETERMINISTIC"
# endif
# ifdef PERL_USE_SAFE_PUTENV
" PERL_USE_SAFE_PUTENV"
# endif
+# ifdef SILENT_NO_TAINT_SUPPORT
+ " SILENT_NO_TAINT_SUPPORT"
+# endif
# ifdef UNLINK_ALL_VERSIONS
" UNLINK_ALL_VERSIONS"
# endif
# ifdef USE_LOCALE_CTYPE
" USE_LOCALE_CTYPE"
# endif
+# ifdef WIN32_NO_REGISTRY
+ " USE_NO_REGISTRY"
+# endif
# ifdef USE_PERL_ATOF
" USE_PERL_ATOF"
# endif
# endif
;
PERL_UNUSED_ARG(cv);
- PERL_UNUSED_ARG(items);
+ PERL_UNUSED_VAR(items);
EXTEND(SP, entries);
PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
sizeof(non_bincompat_options) - 1, SVs_TEMP));
-#ifdef __DATE__
-# ifdef __TIME__
+#ifndef PERL_BUILD_DATE
+# ifdef __DATE__
+# ifdef __TIME__
+# define PERL_BUILD_DATE __DATE__ " " __TIME__
+# else
+# define PERL_BUILD_DATE __DATE__
+# endif
+# endif
+#endif
+
+#ifdef PERL_BUILD_DATE
PUSHs(Perl_newSVpvn_flags(aTHX_
- STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
- SVs_TEMP));
-# else
- PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
+ STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
SVs_TEMP));
-# endif
#else
PUSHs(&PL_sv_undef);
#endif
int argc = PL_origargc;
char **argv = PL_origargv;
const char *scriptname = NULL;
- VOL bool dosearch = FALSE;
+ bool dosearch = FALSE;
char c;
bool doextract = FALSE;
const char *cddir = NULL;
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
+ /* s points to static memory in getenv(), which may be overwritten at
+ * any time; use a mortal copy instead */
+ s = SvPVX(sv_2mortal(newSVpv(s, 0)));
+
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
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, SVfARG(*inc0), 0,
- 0, SVfARG(*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. */
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 MYMALLOC
{
const char *s;
- if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
- dump_mstats("after compilation:");
+ UV uv;
+ s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
+ if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
+ dump_mstats("after compilation:");
}
#endif
int
perl_run(pTHXx)
{
- dVAR;
I32 oldscope;
int ret = 0;
dJMPENV;
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)));
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
- sv_setiv(PL_DBsingle, 1);
+ PL_DBsingle_iv = 1;
if (PL_initav) {
PERL_SET_PHASE(PERL_PHASE_INIT);
call_list(oldscope, PL_initav);
CALLRUNOPS(aTHX);
}
my_exit(0);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
/*
Returns the HV of the specified Perl hash. C<flags> are passed to
C<gv_fetchpv>. If C<GV_ADD> is set and the
Perl variable does not exist then it will be created. If C<flags> is zero
-and the variable does not exist then NULL is returned.
+and the variable does not exist then C<NULL> is returned.
=cut
*/
=for apidoc p||call_argv
Performs a callback to the specified named and package-scoped Perl subroutine
-with C<argv> (a NULL-terminated array of strings) as arguments. See
+with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
L<perlcall>.
Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
/* See G_* flags in cop.h */
/* null terminated arg list */
{
- dVAR;
dSP;
PERL_ARGS_ASSERT_CALL_ARGV;
PUSHMARK(SP);
- if (argv) {
- while (*argv) {
- mXPUSHs(newSVpv(*argv,0));
- argv++;
- }
- PUTBACK;
+ while (*argv) {
+ mXPUSHs(newSVpv(*argv,0));
+ argv++;
}
+ PUTBACK;
return call_pv(sub_name, flags);
}
/*
=for apidoc p||call_sv
-Performs a callback to the Perl sub whose name is in the SV. See
-L<perlcall>.
+Performs a callback to the Perl sub specified by the SV.
+
+If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
+SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
+or C<SvPV(sv)> will be used as the name of the sub to call.
+
+If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
+C<SvPV(sv)> will be used as the name of the method to call.
+
+If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
+the name of the method to call.
+
+Some other values are treated specially for internal use and should
+not be depended on.
+
+See L<perlcall>.
=cut
*/
Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
/* See G_* flags in cop.h */
{
- dVAR; dSP;
+ dVAR;
LOGOP myop; /* fake syntax tree node */
- UNOP method_unop;
- SVOP method_svop;
+ METHOP method_op;
I32 oldmark;
VOL I32 retval = 0;
- I32 oldscope;
bool oldcatch = CATCH_GET;
int ret;
OP* const oldop = PL_op;
SAVEOP();
PL_op = (OP*)&myop;
- EXTEND(PL_stack_sp, 1);
- if (!(flags & G_METHOD_NAMED))
- *++PL_stack_sp = sv;
+ if (!(flags & G_METHOD_NAMED)) {
+ dSP;
+ EXTEND(SP, 1);
+ PUSHs(sv);
+ PUTBACK;
+ }
oldmark = TOPMARK;
- oldscope = PL_scopestack_ix;
if (PERLDB_SUB && PL_curstash != PL_debstash
/* Handle first BEGIN of -d. */
myop.op_private |= OPpENTERSUB_DB;
if (flags & (G_METHOD|G_METHOD_NAMED)) {
+ Zero(&method_op, 1, METHOP);
+ method_op.op_next = (OP*)&myop;
+ PL_op = (OP*)&method_op;
if ( flags & G_METHOD_NAMED ) {
- Zero(&method_svop, 1, SVOP);
- method_svop.op_next = (OP*)&myop;
- method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
- method_svop.op_type = OP_METHOD_NAMED;
- method_svop.op_sv = sv;
- PL_op = (OP*)&method_svop;
+ method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
+ method_op.op_type = OP_METHOD_NAMED;
+ method_op.op_u.op_meth_sv = sv;
} else {
- Zero(&method_unop, 1, UNOP);
- method_unop.op_next = (OP*)&myop;
- method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
- method_unop.op_type = OP_METHOD;
- PL_op = (OP*)&method_unop;
+ method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
+ method_op.op_type = OP_METHOD;
}
myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
myop.op_type = OP_ENTERSUB;
-
}
if (!(flags & G_EVAL)) {
CATCH_SET(oldcatch);
}
else {
+ I32 old_cxix;
myop.op_other = (OP*)&myop;
- PL_markstack_ptr--;
- create_eval_scope(flags|G_FAKINGEVAL);
- PL_markstack_ptr++;
+ (void)POPMARK;
+ old_cxix = cxstack_ix;
+ create_eval_scope(NULL, flags|G_FAKINGEVAL);
+ (void)INCMARK;
JMPENV_PUSH(ret);
FREETMPS;
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
break;
}
- if (PL_scopestack_ix > oldscope)
+ /* if we croaked, depending on how we croaked the eval scope
+ * may or may not have already been popped */
+ if (cxstack_ix > old_cxix) {
+ assert(cxstack_ix == old_cxix + 1);
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
delete_eval_scope();
+ }
JMPENV_POP;
}
=for apidoc p||eval_sv
Tells Perl to C<eval> the string in the SV. It supports the same flags
-as C<call_sv>, with the obvious exception of
G_EVAL. See L<perlcall>.
+as C<call_sv>, with the obvious exception of
C<G_EVAL>. See L<perlcall>.
=cut
*/
/* See G_* flags in cop.h */
{
dVAR;
- dSP;
UNOP myop; /* fake syntax tree node */
- VOL I32 oldmark = SP - PL_stack_base;
+ VOL I32 oldmark;
VOL I32 retval = 0;
int ret;
OP* const oldop = PL_op;
SAVEOP();
PL_op = (OP*)&myop;
Zero(&myop, 1, UNOP);
- EXTEND(PL_stack_sp, 1);
- *++PL_stack_sp = sv;
+ {
+ dSP;
+ oldmark = SP - PL_stack_base;
+ EXTEND(SP, 1);
+ PUSHs(sv);
+ PUTBACK;
+ }
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
/* fail now; otherwise we could fail after the JMPENV_PUSH but
- * before a PUSHEVAL, which corrupts the stack after a croak */
+ * before a cx_pusheval(), which corrupts the stack after a croak */
TAINT_PROPER("eval_sv()");
JMPENV_PUSH(ret);
FREETMPS;
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
/*
=for apidoc p||eval_pv
-Tells Perl to C<eval> the given string and return an SV* result.
+Tells Perl to C<eval> the given string in scalar context and return an SV* result.
=cut
*/
SV*
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
- dVAR;
SV* sv = newSVpv(p, 0);
PERL_ARGS_ASSERT_EVAL_PV;
void
Perl_require_pv(pTHX_ const char *pv)
{
- dVAR;
dSP;
SV* sv;
" L trace some locale setting information--for Perl core development\n",
NULL
};
- int i = 0;
+ UV uv = 0;
PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
if (d)
- i |= 1 << (d - debopts);
+ uv |= 1 << (d - debopts);
else if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"invalid option -D%c, use -D'' to see choices\n", **s);
}
}
else if (isDIGIT(**s)) {
- i = atoi(*s);
+ const char* e;
+ if (grok_atoUV(*s, &uv, &e))
+ *s = e;
for (; isWORDCHAR(**s); (*s)++) ;
}
else if (givehelp) {
const char *const *p = usage_msgd;
while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
}
-# ifdef EBCDIC
- if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "-Dp not implemented on this platform\n");
-# endif
- return i;
+ return (int)uv; /* ignore any UV->int conversion loss */
}
#endif
s--;
}
PL_rs = newSVpvs("");
- SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
+ SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
tmps = (U8*)SvPVX(PL_rs);
uvchr_to_utf8(tmps, rschar);
- SvCUR_set(PL_rs, UNISKIP(rschar));
+ SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
SvUTF8_on(PL_rs);
}
else {
for (s++; isWORDCHAR(*s); s++) ;
#endif
return s;
+ NOT_REACHED; /* NOTREACHED */
}
case 'h':
usage();
+ NOT_REACHED; /* NOTREACHED */
+
case 'i':
Safefree(PL_inplace);
#if defined(__CYGWIN__) /* do backup extension automagically */
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2014, Larry Wall\n");
+ "\n\nCopyright 1987-2016, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
STATIC void
S_init_interp(pTHX)
{
- dVAR;
#ifdef MULTIPLICITY
# define PERLVAR(prefix,var,type)
# define PERLVARA(prefix,var,n,type)
STATIC void
S_init_main_stash(pTHX)
{
- dVAR;
GV *gv;
PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
GvMULTI_on(PL_replgv);
(void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
#ifdef PERL_DONT_CREATE_GVSV
- gv_SVadd(PL_errgv);
+ (void)gv_SVadd(PL_errgv);
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
CLEAR_ERRSV();
{
int fdscript = -1;
PerlIO *rsfp = NULL;
- dVAR;
Stat_t tmpstatbuf;
int fd;
PL_origfilename = savepvs("-e");
}
else {
+ const char *s;
+ UV uv;
/* if find_script() returns, it returns a malloc()-ed value */
scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
- if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
- const char *s = scriptname + 8;
- fdscript = atoi(s);
- while (isDIGIT(*s))
- s++;
+ if (strnEQ(scriptname, "/dev/fd/", 8)
+ && isDIGIT(scriptname[8])
+ && grok_atoUV(scriptname + 8, &uv, &s)
+ && uv <= PERL_INT_MAX
+ ) {
+ fdscript = (int)uv;
if (*s) {
/* PSz 18 Feb 04
* Tell apart "normal" usage of fdscript, e.g.
const char * const err = "Failed to create a fake bit bucket";
if (strEQ(scriptname, BIT_BUCKET)) {
#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
- int old_umask = umask(0600);
+ int old_umask = umask(0177);
int tmpfd = mkstemp(tmpname);
umask(old_umask);
if (tmpfd > -1) {
CopFILE(PL_curcop), Strerror(errno));
}
fd = PerlIO_fileno(rsfp);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
if (fd >= 0) {
/* ensure close-on-exec */
- if (fcntl(fd, F_SETFD, 1) < 0) {
+ if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
}
if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
dVAR;
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");
- }
+ Stat_t statbuf;
+ if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
+ Perl_croak_nocontext( "Illegal suidscript");
}
- if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+ if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
- (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+ (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
)
if (!PL_do_undump)
Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
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. */
#ifndef NO_TAINT_SUPPORT
- dVAR;
const Uid_t my_uid = PerlProc_getuid();
const Uid_t my_euid = PerlProc_geteuid();
const Gid_t my_gid = PerlProc_getgid();
const Gid_t my_egid = PerlProc_getegid();
+ PERL_UNUSED_CONTEXT;
+
/* Should not happen: */
CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
* if -T are the first chars together; otherwise one gets
* "Too late" message. */
if ( argc > 1 && argv[1][0] == '-'
- && (argv[1][1] == 't' || argv[1][1] == 'T') )
+ && isALPHA_FOLD_EQ(argv[1][1], 't'))
return 1;
return 0;
}
STATIC void
S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
{
- dVAR;
char string[3] = "-x";
const char *message = "program input from stdin";
+ PERL_UNUSED_CONTEXT;
if (flag) {
string[1] = flag;
message = string;
void
Perl_init_debugger(pTHX)
{
- dVAR;
HV * const ostash = PL_curstash;
+ MAGIC *mg;
PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsingle))
sv_setiv(PL_DBsingle, 0);
+ mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SINGLE;
+ SvSETMAGIC(PL_DBsingle);
+
PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBtrace))
sv_setiv(PL_DBtrace, 0);
+ mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_TRACE;
+ SvSETMAGIC(PL_DBtrace);
+
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsignal))
sv_setiv(PL_DBsignal, 0);
+ mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SIGNAL;
+ SvSETMAGIC(PL_DBsignal);
+
SvREFCNT_dec(PL_curstash);
PL_curstash = ostash;
}
void
Perl_init_stacks(pTHX)
{
- dVAR;
+ SSize_t size;
+
/* start with 128-item stack and 8K cxstack */
PL_curstackinfo = new_stackinfo(REASONABLE(128),
REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
PL_scopestack_ix = 0;
PL_scopestack_max = REASONABLE(32);
- Newx(PL_savestack,REASONABLE_but_at_least(128,SS_MAXPUSH),ANY);
+ size = REASONABLE_but_at_least(128,SS_MAXPUSH);
+ Newx(PL_savestack, size, ANY);
PL_savestack_ix = 0;
- PL_savestack_max = REASONABLE_but_at_least(128,SS_MAXPUSH);
+ /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
+ PL_savestack_max = size - SS_MAXPUSH;
}
#undef REASONABLE
STATIC void
S_nuke_stacks(pTHX)
{
- dVAR;
while (PL_curstackinfo->si_next)
PL_curstackinfo = PL_curstackinfo->si_next;
while (PL_curstackinfo) {
STATIC void
S_init_predump_symbols(pTHX)
{
- dVAR;
GV *tmpgv;
IO *io;
void
Perl_init_argv_symbols(pTHX_ int argc, char **argv)
{
- dVAR;
-
PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
argc--,argv++; /* skip name of script */
STATIC void
S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
GV* tmpgv;
PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
}
if (env) {
char *s, *old_var;
+ STRLEN nlen;
SV *sv;
+ HV *dups = newHV();
+
for (; *env; env++) {
old_var = *env;
if (!(s = strchr(old_var,'=')) || s == old_var)
continue;
+ nlen = s - old_var;
#if defined(MSDOS) && !defined(DJGPP)
*s = '\0';
(void)strupr(old_var);
*s = '=';
#endif
- sv = newSVpv(s+1, 0);
- (void)hv_store(hv, old_var, s - old_var, sv, 0);
+ if (hv_exists(hv, old_var, nlen)) {
+ const char *name = savepvn(old_var, nlen);
+
+ /* make sure we use the same value as getenv(), otherwise code that
+ uses getenv() (like setlocale()) might see a different value to %ENV
+ */
+ sv = newSVpv(PerlEnv_getenv(name), 0);
+
+ /* keep a count of the dups of this name so we can de-dup environ later */
+ if (hv_exists(dups, name, nlen))
+ ++SvIVX(*hv_fetch(dups, name, nlen, 0));
+ else
+ (void)hv_store(dups, name, nlen, newSViv(1), 0);
+
+ Safefree(name);
+ }
+ else {
+ sv = newSVpv(s+1, 0);
+ }
+ (void)hv_store(hv, old_var, nlen, sv, 0);
if (env_is_not_environ)
mg_set(sv);
}
+ if (HvKEYS(dups)) {
+ /* environ has some duplicate definitions, remove them */
+ HE *entry;
+ hv_iterinit(dups);
+ while ((entry = hv_iternext_flags(dups, 0))) {
+ STRLEN nlen;
+ const char *name = HePV(entry, nlen);
+ IV count = SvIV(HeVAL(entry));
+ IV i;
+ SV **valp = hv_fetch(hv, name, nlen, 0);
+
+ assert(valp);
+
+ /* try to remove any duplicate names, depending on the
+ * implementation used in my_setenv() the iteration might
+ * not be necessary, but let's be safe.
+ */
+ for (i = 0; i < count; ++i)
+ my_setenv(name, 0);
+
+ /* and set it back to the value we set $ENV{name} to */
+ my_setenv(name, SvPV_nolen(*valp));
+ }
+ }
+ SvREFCNT_dec_NN(dups);
}
#endif /* USE_ENVIRON_ARRAY */
#endif /* !PERL_MICRO */
STATIC void
S_init_perllib(pTHX)
{
- dVAR;
#ifndef VMS
const char *perl5lib = NULL;
#endif
*/
char buf[256];
int idx = 0;
- if (my_trnlnm("PERL5LIB",buf,0))
+ if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
do {
incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
- } while (my_trnlnm("PERL5LIB",buf,++idx));
+ } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
else {
- while (my_trnlnm("PERLLIB",buf,idx++))
+ while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
incpush_use_sep(buf, 0, 0);
}
#endif /* VMS */
#ifdef SITELIB_EXP
# if defined(WIN32)
/* this picks up sitearch as well */
- s = win32_get_sitelib(PERL_FS_VERSION, &len);
+ s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
/* this picks up vendorarch as well */
- s = win32_get_vendorlib(PERL_FS_VERSION, &len);
+ s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
#endif
#if defined(WIN32)
- s = win32_get_privlib(PERL_FS_VERSION, &len);
+ s = PerlEnv_lib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
#else
*/
char buf[256];
int idx = 0;
- if (my_trnlnm("PERL5LIB",buf,0))
+ if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
do {
incpush_use_sep(buf, 0,
INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
- } while (my_trnlnm("PERL5LIB",buf,++idx));
+ } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
#endif /* VMS */
}
STATIC SV *
S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
{
- dVAR;
Stat_t tmpstatbuf;
PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
STATIC void
S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
{
- dVAR;
#ifndef PERL_IS_MINIPERL
const U8 using_sub_dirs
= (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
- dVAR;
SV *atsv;
- volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
+ VOL const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
CV *cv;
STRLEN len;
int ret;
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_curcop = &PL_compiling;
void
Perl_my_exit(pTHX_ U32 status)
{
- dVAR;
if (PL_exit_flags & PERL_EXIT_ABORT) {
abort();
}
void
Perl_my_failure_exit(pTHX)
{
- dVAR;
#ifdef VMS
/* We have been called to fall on our sword. The desired exit code
* should be already set in STATUS_UNIX, but could be shifted over
STATIC void
S_my_exit_jump(pTHX)
{
- dVAR;
-
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_e_script = NULL;
}
POPSTACK_TO(PL_mainstack);
- dounwind(-1);
+ if (cxstack_ix >= 0) {
+ dounwind(-1);
+ cx_popblock(cxstack);
+ }
LEAVE_SCOPE(0);
JMPENV_JUMP(2);
static I32
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- dVAR;
const char * const p = SvPVX_const(PL_e_script);
const char *nl = strchr(p, '\n');
return 1;
}
+/* removes boilerplate code at the end of each boot_Module xsub */
+void
+Perl_xs_boot_epilog(pTHX_ const I32 ax)
+{
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ XSRETURN_YES;
+}
+
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff