/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
- * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
* by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* function of the interpreter; that can be found in perlmain.c
*/
-#ifdef PERL_IS_MINIPERL
+#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
# define USE_SITECUSTOMIZE
#endif
static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
-/* Drop everything. Heck, don't even try to call it */
-# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) NOOP
+# define validate_suid(rsfp) NOOP
#else
-/* Drop almost everything */
-# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
+# define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
#endif
#define CALL_BODY_SUB(myop) \
#define CALL_LIST_BODY(cv) \
PUSHMARK(PL_stack_sp); \
- call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD);
+ call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
ALLOC_THREAD_KEY;
PERL_SET_THX(my_perl);
OP_REFCNT_INIT;
+ OP_CHECK_MUTEX_INIT;
HINTS_REFCNT_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
MUTEX_INIT(&PL_my_ctx_mutex);
else all hell breaks loose in S_find_uninit_var(). */
Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
PL_regex_pad = AvARRAY(PL_regex_padav);
+ Newxz(PL_stashpad, PL_stashpadmax, HV *);
#endif
#ifdef USE_REENTRANT_API
Perl_reentrant_init(aTHX);
#endif
CopFILE_free(&PL_compiling);
- CopSTASH_free(&PL_compiling);
/* The exit() function will do everything that needs doing. */
return STATUS_EXIT;
* REGEXPs in the parent interpreter
* we need to manually ReREFCNT_dec for the clones
*/
- SvREFCNT_dec(PL_regex_padav);
- PL_regex_padav = NULL;
- PL_regex_pad = NULL;
+ {
+ I32 i = AvFILLp(PL_regex_padav);
+ SV **ary = AvARRAY(PL_regex_padav);
+
+ for (; i; i--) {
+ SvREFCNT_dec(ary[i]);
+ ary[i] = &PL_sv_undef;
+ }
+ }
+ Safefree(PL_stashpad);
#endif
+
SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
PL_stashcache = NULL;
cophh_free(CopHINTHASH_get(&PL_compiling));
CopHINTHASH_set(&PL_compiling, cophh_new_empty());
CopFILE_free(&PL_compiling);
- CopSTASH_free(&PL_compiling);
/* Prepare to destruct main symbol table. */
(long)cxstack_ix + 1);
}
+#ifdef USE_ITHREADS
+ SvREFCNT_dec(PL_regex_padav);
+ PL_regex_padav = NULL;
+ PL_regex_pad = NULL;
+#endif
+
#ifdef PERL_IMPLICIT_CONTEXT
/* the entries in this list are allocated via SV PVX's, so get freed
* in sv_clean_all */
Safefree(PL_origfilename);
PL_origfilename = NULL;
- Safefree(PL_reg_start_tmp);
- PL_reg_start_tmp = (char**)NULL;
- PL_reg_start_tmpl = 0;
Safefree(PL_reg_curpm);
Safefree(PL_reg_poscache);
free_tied_hv_pool();
# ifdef PERL_PRESERVE_IVUV
" PERL_PRESERVE_IVUV"
# endif
+# ifdef PERL_RELOCATABLE_INCPUSH
+ " PERL_RELOCATABLE_INCPUSH"
+# endif
# ifdef PERL_USE_DEVEL
" PERL_USE_DEVEL"
# endif
#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
#endif
- SV *linestr_sv = newSV_type(SVt_PVIV);
+ SV *linestr_sv = NULL;
bool add_read_e_script = FALSE;
+ U32 lex_start_flags = 0;
PERL_SET_PHASE(PERL_PHASE_START);
- SvGROW(linestr_sv, 80);
- sv_setpvs(linestr_sv,"");
-
init_main_stash();
{
# else
/* SITELIB_EXP is a function call on Win32. */
const char *const raw_sitelib = SITELIB_EXP;
- /* process .../.. if PERL_RELOCATABLE_INC is defined */
- SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
- INCPUSH_CAN_RELOCATE);
- const char *const sitelib = SvPVX(sitelib_sv);
- (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));
- assert (SvREFCNT(sitelib_sv) == 1);
- SvREFCNT_dec(sitelib_sv);
+ if (raw_sitelib) {
+ /* process .../.. if PERL_RELOCATABLE_INC is defined */
+ SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
+ INCPUSH_CAN_RELOCATE);
+ const char *const sitelib = SvPVX(sitelib_sv);
+ (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));
+ assert (SvREFCNT(sitelib_sv) == 1);
+ SvREFCNT_dec(sitelib_sv);
+ }
# endif
}
#endif
{
bool suidscript = FALSE;
- open_script(scriptname, dosearch, &suidscript, &rsfp);
+ rsfp = open_script(scriptname, dosearch, &suidscript);
+ if (!rsfp) {
+ rsfp = PerlIO_stdin();
+ lex_start_flags = LEX_DONT_CLOSE_RSFP;
+ }
- validate_suid(validarg, scriptname, fdscript, suidscript,
- linestr_sv, rsfp);
+ validate_suid(rsfp);
#ifndef PERL_MICRO
# if defined(SIGCHLD) || defined(SIGCLD)
forbid_setid('x', suidscript);
/* Hence you can't get here if suidscript is true */
+ linestr_sv = newSV_type(SVt_PV);
+ lex_start_flags |= LEX_START_COPIED;
find_beginning(linestr_sv, rsfp);
if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
}
#endif
- lex_start(linestr_sv, rsfp, 0);
+ lex_start(linestr_sv, rsfp, lex_start_flags);
+ if(linestr_sv)
+ SvREFCNT_dec(linestr_sv);
+
PL_subname = newSVpvs("main");
if (add_read_e_script)
POPSTACK_TO(PL_mainstack);
goto redo_body;
}
- PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
FREETMPS;
ret = 1;
break;
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;
/* fail now; otherwise we could fail after the JMPENV_PUSH but
* before a PUSHEVAL, which corrupts the stack after a croak */
case 'S': /* OS/2 needs -S on "extproc" line. */
break;
#endif
- default:
+ case 'e': case 'f': case 'x': case 'E':
+#ifndef ALTERNATE_SHEBANG
+ case 'S':
+#endif
+ case 'V':
Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
+ default:
+ Perl_croak(aTHX_
+ "Unrecognized switch: -%.1s (-h will show valid options)",s
+ );
}
return NULL;
}
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2011, Larry Wall\n");
+ "\n\nCopyright 1987-2012, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PerlIO_stdout(),
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
/* unexec() can be found in the Gnu emacs distribution */
/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
+#ifdef VMS
+#include <lib$routines.h>
+#endif
+
void
Perl_my_unexec(pTHX)
{
PerlProc_exit(status);
#else
# ifdef VMS
-# include <lib$routines.h>
lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
# elif defined(WIN32) || defined(__CYGWIN__)
Perl_croak(aTHX_ "dump is not supported");
sv_setpvs(get_sv("/", GV_ADD), "\n");
}
-STATIC int
-S_open_script(pTHX_ const char *scriptname, bool dosearch,
- bool *suidscript, PerlIO **rsfpp)
+STATIC PerlIO *
+S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
{
int fdscript = -1;
+ PerlIO *rsfp = NULL;
dVAR;
PERL_ARGS_ASSERT_OPEN_SCRIPT;
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = (char *)"";
if (fdscript >= 0) {
- *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
-# if defined(HAS_FCNTL) && defined(F_SETFD)
- if (*rsfpp)
- /* ensure close-on-exec */
- fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
-# endif
+ rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
}
else if (!*scriptname) {
forbid_setid(0, *suidscript);
- *rsfpp = PerlIO_stdin();
+ return NULL;
}
else {
#ifdef FAKE_BIT_BUCKET
#endif
}
#endif
- *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+ rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
#ifdef FAKE_BIT_BUCKET
if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
}
scriptname = BIT_BUCKET;
#endif
-# if defined(HAS_FCNTL) && defined(F_SETFD)
- if (*rsfpp)
- /* ensure close-on-exec */
- fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
-# endif
}
- if (!*rsfpp) {
+ if (!rsfp) {
/* PSz 16 Sep 03 Keep neat error message */
if (PL_e_script)
Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
}
- return fdscript;
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ /* ensure close-on-exec */
+ fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+#endif
+ return rsfp;
}
/* Mention
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();
+
PERL_ARGS_ASSERT_VALIDATE_SUID;
- if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
+ 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 ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+ if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
||
- (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+ (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\
S_init_ids(pTHX)
{
dVAR;
- PL_uid = PerlProc_getuid();
- PL_euid = PerlProc_geteuid();
- PL_gid = PerlProc_getgid();
- PL_egid = PerlProc_getegid();
-#ifdef VMS
- PL_uid |= PL_gid << 16;
- PL_euid |= PL_egid << 16;
-#endif
+ const UV my_uid = PerlProc_getuid();
+ const UV my_euid = PerlProc_geteuid();
+ const UV my_gid = PerlProc_getgid();
+ const UV my_egid = PerlProc_getegid();
+
/* Should not happen: */
- CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
+ PL_tainting |= (my_uid && (my_euid != my_uid || my_egid != my_gid));
/* BUG */
/* PSz 27 Feb 04
* Should go by suidscript, not uid!=euid: why disallow
}
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
- if (PL_euid != PL_uid)
+ if (PerlProc_getuid() != PerlProc_geteuid())
Perl_croak(aTHX_ "No %s allowed while running setuid", message);
- if (PL_egid != PL_gid)
+ if (PerlProc_getgid() != PerlProc_getegid())
Perl_croak(aTHX_ "No %s allowed while running setgid", message);
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
if (suidscript)
"leak" until global destruction. */
av_clear(args);
if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
- sv_unmagic((SV *)args, PERL_MAGIC_tied);
+ Perl_croak(aTHX_ "Cannot set tied @DB::args");
}
AvREIFY_only(PL_dbargs);
}
GvMULTI_on(tmpgv);
GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
- PL_statname = newSV(0); /* last filename we did stat on */
+ PL_statname = newSVpvs(""); /* last filename we did stat on */
}
void
#endif /* !PERL_MICRO */
}
TAINT_NOT;
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = (IV)getppid();
-#endif
/* touch @F array to prevent spurious warnings 20020415 MJD */
if (PL_minus_a) {
/* And this is the new libdir. */
libdir = tempsv;
if (PL_tainting &&
- (PL_uid != PL_euid || PL_gid != PL_egid)) {
+ (PerlProc_getuid() != PerlProc_geteuid() ||
+ PerlProc_getgid() != PerlProc_getegid())) {
/* Need to taint relocated paths if running set ID */
SvTAINTED_on(libdir);
}
CopLINE_set(PL_curcop, oldline);
JMPENV_JUMP(3);
}
- PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
FREETMPS;
break;
}
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff