This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Epigraph for v5.15.9
[perl5.git] / perl.c
diff --git a/perl.c b/perl.c
index 0f67ff1..1737893 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2,7 +2,7 @@
 /*    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
@@ -77,11 +77,9 @@ char *getenv (char *); /* Usually in <stdlib.h> */
 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) \
@@ -92,7 +90,7 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 
 #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)
@@ -105,6 +103,7 @@ 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);
@@ -1715,6 +1714,9 @@ S_Internals_V(pTHX_ CV *cv)
 #  ifdef PERL_PRESERVE_IVUV
                             " PERL_PRESERVE_IVUV"
 #  endif
+#  ifdef PERL_RELOCATABLE_INCPUSH
+                            " PERL_RELOCATABLE_INCPUSH"
+#  endif
 #  ifdef PERL_USE_DEVEL
                             " PERL_USE_DEVEL"
 #  endif
@@ -1797,14 +1799,12 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #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();
 
     {
@@ -2069,10 +2069,13 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     {
        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)
@@ -2097,6 +2100,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
            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);
@@ -2224,7 +2229,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     }
 #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)
@@ -3610,11 +3618,11 @@ S_init_main_stash(pTHX)
     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;
@@ -3664,16 +3672,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
     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
@@ -3708,7 +3711,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
 #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)
@@ -3717,13 +3720,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
        }
        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));
@@ -3731,7 +3729,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
            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
@@ -3748,15 +3750,20 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
 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\
@@ -3800,17 +3807,14 @@ STATIC void
 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
@@ -3876,9 +3880,9 @@ S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
     }
 
 #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)
@@ -4203,9 +4207,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 #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) {
@@ -4565,7 +4566,8 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
                    /* 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);
                    }
Unnamed repository; edit this file 'description' to name the repository.