In S_validate_suid(), move declarations after the first statement.

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 1219e99..5518675 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
@@ -92,7 +92,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 +105,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);
@@ -1688,9 +1689,6 @@ S_Internals_V(pTHX_ CV *cv)
 #  ifdef DEBUGGING
                             " DEBUGGING"
 #  endif
-#  ifdef HOMEGROWN_POSIX_SIGNALS
-                            " HOMEGROWN_POSIX_SIGNALS"
-#  endif
 #  ifdef NO_MATHOMS
                             " NO_MATHOMS"
 #  endif
@@ -1718,6 +1716,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
@@ -1938,15 +1939,12 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
                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:
@@ -2336,7 +2334,7 @@ perl_run(pTHXx)
            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;
@@ -3360,8 +3358,16 @@ Perl_moreswitches(pTHX_ const char *s)
     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;
 }
@@ -3420,7 +3426,7 @@ S_minus_v(pTHX)
 #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");
@@ -3746,15 +3752,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\
@@ -3798,17 +3809,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
@@ -3874,9 +3882,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)
@@ -3895,6 +3903,8 @@ Perl_init_dbargs(pTHX)
           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);
 }
@@ -4084,7 +4094,7 @@ S_init_predump_symbols(pTHX)
     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
@@ -4199,9 +4209,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) {
@@ -4561,7 +4568,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);
                    }
@@ -4816,7 +4824,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                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;
        }