/* 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
#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);
=cut
*/
+#define SET_CURSTASH(newstash) \
+ if (PL_curstash != newstash) { \
+ SvREFCNT_dec(PL_curstash); \
+ PL_curstash = (HV *)SvREFCNT_inc(newstash); \
+ }
+
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
if (PL_unitcheckav) {
call_list(oldscope, PL_unitcheckav);
}
# ifdef DEBUGGING
" DEBUGGING"
# endif
-# ifdef HOMEGROWN_POSIX_SIGNALS
- " HOMEGROWN_POSIX_SIGNALS"
-# endif
# ifdef NO_MATHOMS
" NO_MATHOMS"
# endif
# ifdef PERL_PRESERVE_IVUV
" PERL_PRESERVE_IVUV"
# endif
+# ifdef PERL_RELOCATABLE_INCPUSH
+ " PERL_RELOCATABLE_INCPUSH"
+# endif
# ifdef PERL_USE_DEVEL
" PERL_USE_DEVEL"
# endif
argc--,argv++;
goto switch_end;
}
- /* catch use of gnu style long options */
- if (strEQ(s, "version")) {
- s = (char *)"v";
- goto reswitch;
- }
- if (strEQ(s, "help")) {
- s = (char *)"h";
- goto reswitch;
- }
+ /* catch use of gnu style long options.
+ Both of these exit immediately. */
+ if (strEQ(s, "version"))
+ minus_v();
+ if (strEQ(s, "help"))
+ usage();
s--;
/* FALL THROUGH */
default:
}
}
+ /* Set $^X early so that it can be used for relocatable paths in @INC */
+ /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
+ assert (!PL_tainted);
+ TAINT;
+ S_set_caret_X(aTHX);
+ TAINT_NOT;
+
#if defined(USE_SITECUSTOMIZE)
if (!minus_f) {
/* The games with local $! are to avoid setting errno if there is no
- sitecustomize script. */
+ sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
+ ie a q() operator with a NUL byte as a the delimiter. This avoids
+ problems with pathnames containing (say) ' */
# ifdef PERL_IS_MINIPERL
AV *const inc = GvAV(PL_incgv);
SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
if (inc0) {
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
Perl_newSVpvf(aTHX_
- "BEGIN { do {local $!; -f '%"SVf"/buildcustomize.pl'} && do '%"SVf"/buildcustomize.pl' }", *inc0, *inc0));
+ "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} && do q%c%"SVf"/buildcustomize.pl%c }",
+ 0, *inc0, 0,
+ 0, *inc0, 0));
}
# else
/* SITELIB_EXP is a function call on Win32. */
- const char *const sitelib = SITELIB_EXP;
+ 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 '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib));
+ "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
scriptname = "-";
}
- /* Set $^X early so that it can be used for relocatable paths in @INC */
assert (!PL_tainted);
- TAINT;
- S_set_caret_X(aTHX);
- TAINT_NOT;
init_perllib();
{
}
}
CopLINE_set(PL_curcop, 0);
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_e_script = NULL;
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
PL_endav && !PL_minus_c) {
PERL_SET_PHASE(PERL_PHASE_END);
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;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
FREETMPS;
JMPENV_POP;
my_exit_jump();
/* FALL THROUGH */
case 2:
/* my_exit() was called */
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
FREETMPS;
JMPENV_POP;
my_exit_jump();
}
STATIC void
-S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
+S_usage(pTHX) /* XXX move this out into a module ? */
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that option. Others? */
const char * const *p = usage_msg;
PerlIO *out = PerlIO_stdout();
- PERL_ARGS_ASSERT_USAGE;
-
PerlIO_printf(out,
"\nUsage: %s [switches] [--] [programfile] [arguments]\n",
- name);
+ PL_origargv[0]);
while (*p)
PerlIO_puts(out, *p++);
+ my_exit(0);
}
/* convert a string of -D options (or digits) into an int.
return s;
}
case 'h':
- usage(PL_origargv[0]);
- my_exit(0);
+ usage();
case 'i':
Safefree(PL_inplace);
#if defined(__CYGWIN__) /* do backup extension automagically */
s++;
return s;
case 't':
+ case 'T':
if (!PL_tainting)
- TOO_LATE_FOR('t');
+ TOO_LATE_FOR(*s);
s++;
- return s;
- case 'T':
- if (!PL_tainting)
- TOO_LATE_FOR('T');
- s++;
return s;
case 'u':
PL_do_undump = TRUE;
s++;
return s;
case 'v':
+ minus_v();
+ case 'w':
+ if (! (PL_dowarn & G_WARN_ALL_MASK)) {
+ PL_dowarn |= G_WARN_ON;
+ }
+ s++;
+ return s;
+ case 'W':
+ PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+ if (!specialWARN(PL_compiling.cop_warnings))
+ PerlMemShared_free(PL_compiling.cop_warnings);
+ PL_compiling.cop_warnings = pWARN_ALL ;
+ s++;
+ return s;
+ case 'X':
+ PL_dowarn = G_WARN_ALL_OFF;
+ if (!specialWARN(PL_compiling.cop_warnings))
+ PerlMemShared_free(PL_compiling.cop_warnings);
+ PL_compiling.cop_warnings = pWARN_NONE ;
+ s++;
+ return s;
+ case '*':
+ case ' ':
+ while( *s == ' ' )
+ ++s;
+ if (s[0] == '-') /* Additional switches on #! line. */
+ return s+1;
+ break;
+ case '-':
+ case 0:
+#if defined(WIN32) || !defined(PERL_STRICT_CR)
+ case '\r':
+#endif
+ case '\n':
+ case '\t':
+ break;
+#ifdef ALTERNATE_SHEBANG
+ case 'S': /* OS/2 needs -S on "extproc" line. */
+ break;
+#endif
+ 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;
+}
+
+
+STATIC void
+S_minus_v(pTHX)
+{
if (!sv_derived_from(PL_patchlevel, "version"))
upg_version(PL_patchlevel, TRUE);
#if !defined(DGUX)
#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");
this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
my_exit(0);
- case 'w':
- if (! (PL_dowarn & G_WARN_ALL_MASK)) {
- PL_dowarn |= G_WARN_ON;
- }
- s++;
- return s;
- case 'W':
- PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_ALL ;
- s++;
- return s;
- case 'X':
- PL_dowarn = G_WARN_ALL_OFF;
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_NONE ;
- s++;
- return s;
- case '*':
- case ' ':
- while( *s == ' ' )
- ++s;
- if (s[0] == '-') /* Additional switches on #! line. */
- return s+1;
- break;
- case '-':
- case 0:
-#if defined(WIN32) || !defined(PERL_STRICT_CR)
- case '\r':
-#endif
- case '\n':
- case '\t':
- break;
-#ifdef ALTERNATE_SHEBANG
- case 'S': /* OS/2 needs -S on "extproc" line. */
- break;
-#endif
- default:
- Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
- }
- return NULL;
}
/* compliments of Tom Christiansen */
dVAR;
GV *gv;
- PL_curstash = PL_defstash = newHV();
+ PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
/* We know that the string "main" will be in the global shared string
table, so it's a small saving to use it rather than allocate another
8 bytes. */
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
CLEAR_ERRSV();
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
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)
It might have entries, and if we just turn off AvREAL(), they will
"leak" until global destruction. */
av_clear(args);
+ if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
+ Perl_croak(aTHX_ "Cannot set tied @DB::args");
}
AvREIFY_only(PL_dbargs);
}
dVAR;
HV * const ostash = PL_curstash;
- PL_curstash = PL_debstash;
+ PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
Perl_init_dbargs(aTHX);
PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsignal))
sv_setiv(PL_DBsignal, 0);
+ SvREFCNT_dec(PL_curstash);
PL_curstash = ostash;
}
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) {
}
#endif
-STATIC void
-S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
+STATIC SV *
+S_mayberelocate(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
- |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
- const U8 add_versioned_sub_dirs
- = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
- const U8 add_archonly_sub_dirs
- = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
-#ifdef PERL_INC_VERSION_LIST
- const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
-#endif
-#endif
const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
- const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
- const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
- AV *const inc = GvAVn(PL_incgv);
+ SV *libdir;
- PERL_ARGS_ASSERT_INCPUSH;
+ PERL_ARGS_ASSERT_MAYBERELOCATE;
assert(len > 0);
- /* Could remove this vestigial extra block, if we don't mind a lot of
- re-indenting diff noise. */
- {
- SV *libdir;
- /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
- arranged to unshift #! line -I onto the front of @INC. However,
- -I can add version and architecture specific libraries, and they
- need to go first. The old code assumed that it was always
- pushing. Hence to make it work, need to push the architecture
- (etc) libraries onto a temporary array, then "unshift" that onto
- the front of @INC. */
-#ifndef PERL_IS_MINIPERL
- AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
-#endif
-
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
}
#ifdef VMS
+ {
char *unix;
- STRLEN len;
if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
len = strlen(unix);
else
PerlIO_printf(Perl_error_log,
"Failed to unixify @INC element \"%s\"\n",
- SvPV(libdir,len));
+ SvPV_nolen_const(libdir));
+ }
#endif
/* Do the if() outside the #ifdef to avoid warnings about an unused
/* 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);
}
}
#endif
}
+ return libdir;
+}
+
+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
+ |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
+ const U8 add_versioned_sub_dirs
+ = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
+ const U8 add_archonly_sub_dirs
+ = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
+#ifdef PERL_INC_VERSION_LIST
+ const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
+#endif
+#endif
+ const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
+ const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
+ AV *const inc = GvAVn(PL_incgv);
+
+ PERL_ARGS_ASSERT_INCPUSH;
+ assert(len > 0);
+
+ /* Could remove this vestigial extra block, if we don't mind a lot of
+ re-indenting diff noise. */
+ {
+ SV *const libdir = mayberelocate(dir, len, flags);
+ /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
+ arranged to unshift #! line -I onto the front of @INC. However,
+ -I can add version and architecture specific libraries, and they
+ need to go first. The old code assumed that it was always
+ pushing. Hence to make it work, need to push the architecture
+ (etc) libraries onto a temporary array, then "unshift" that onto
+ the front of @INC. */
#ifndef PERL_IS_MINIPERL
+ AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
+
/*
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
*/
if (using_sub_dirs) {
- SV *subdir;
+ SV *subdir = newSVsv(libdir);
#ifdef PERL_INC_VERSION_LIST
/* Configure terminates PERL_INC_VERSION_LIST with a NULL */
const char * const incverlist[] = { PERL_INC_VERSION_LIST };
const char * const *incver;
#endif
- subdir = newSVsv(libdir);
if (add_versioned_sub_dirs) {
/* .../version/archname if -d .../version/archname */
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
- PL_curstash = PL_defstash;
+ SET_CURSTASH(PL_defstash);
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
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;
}
https://perl5.git.perl.org / perl5.git / blobdiff