*
* 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.
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(Sentence_Break_invlist);
- PL_WB_invlist = _new_invlist_C_array(Word_Break_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;
}
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
PL_XPosix_ptrs[i] = NULL;
}
PL_GCB_invlist = NULL;
+ PL_LB_invlist = NULL;
PL_SB_invlist = NULL;
PL_WB_invlist = NULL;
const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
if (s && strEQ(s, "1")) {
- unsigned char *seed= PERL_HASH_SEED;
- unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
+ 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 USE_LOCALE_CTYPE
" USE_LOCALE_CTYPE"
# endif
+# ifdef WIN32_NO_REGISTRY
+ " USE_NO_REGISTRY"
+# endif
# ifdef USE_PERL_ATOF
" USE_PERL_ATOF"
# endif
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
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)>.
/*
=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 */
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. */
CATCH_SET(oldcatch);
}
else {
+ I32 old_cxix;
myop.op_other = (OP*)&myop;
- PL_markstack_ptr--;
- create_eval_scope(flags|G_FAKINGEVAL);
- PL_markstack_ptr++;
+ (void)POPMARK;
+ old_cxix = cxstack_ix;
+ create_eval_scope(NULL, flags|G_FAKINGEVAL);
+ (void)INCMARK;
JMPENV_PUSH(ret);
break;
}
- 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);
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 {
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2015, 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");
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\
void
Perl_init_stacks(pTHX)
{
+ 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
}
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 */
*/
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 */
*/
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 */
}
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
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;
}
POPSTACK_TO(PL_mainstack);
- dounwind(-1);
+ if (cxstack_ix >= 0) {
+ dounwind(-1);
+ cx_popblock(cxstack);
+ }
LEAVE_SCOPE(0);
JMPENV_JUMP(2);
/* removes boilerplate code at the end of each boot_Module xsub */
void
-Perl_xs_boot_epilog(pTHX_ const U32 ax)
+Perl_xs_boot_epilog(pTHX_ const I32 ax)
{
if (PL_unitcheckav)
call_list(PL_scopestack_ix, PL_unitcheckav);