Eliminating PL_suidscript is more tricky, and requires changing the

prototype of Perl_moreswitches.

p4raw-id: //depot/perl@27070

8 files changed, 58 insertions, 57 deletions

diff --git a/embed.fnc b/embed.fnc
index 35edb4fb97..16d1d0219a 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -469,7 +469,7 @@ Ap	|I32	|mg_size	|NN SV* sv
 Ap	|void	|mini_mktime	|NN struct tm *pm
 p	|OP*	|mod		|NULLOK OP* o|I32 type
 p	|int	|mode_from_discipline|NULLOK SV* discp
-Ap	|char*	|moreswitches	|NN char* s
+Ap	|char*	|moreswitches	|NN char* s|int suidscript
 p	|OP*	|my		|NN OP* o
 Ap	|NV	|my_atof	|NN const char *s
 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
@@ -1134,8 +1134,8 @@ Ap	|void	|Slab_Free	|NN void *op
 #endif
 
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
-s	|void	|find_beginning
-s	|void	|forbid_setid	|char flag
+s	|void	|find_beginning	|int suidscript
+s	|void	|forbid_setid	|char flag|int suidscript
 s	|void	|incpush	|NULLOK const char *dir|bool addsubdirs|bool addoldvers|bool usesep|bool canrelocate
 s	|void	|init_interp
 s	|void	|init_ids
@@ -1146,10 +1146,12 @@ s	|void	|init_postdump_symbols|int argc|NN char **argv|NULLOK char **env
 s	|void	|init_predump_symbols
 rs	|void	|my_exit_jump
 s	|void	|nuke_stacks
-s	|int	|open_script	|NN const char *scriptname|bool dosearch|NN SV *sv
+s	|int	|open_script	|NN const char *scriptname|bool dosearch \
+				|NN SV *sv|NN int *suidscript
 s	|void	|usage		|NN const char *name
 s	|void	|validate_suid	|NN const char *validarg \
-				|NN const char *scriptname|int fdscript
+				|NN const char *scriptname|int fdscript \
+				|int suidscript
 #  if defined(IAMSUID)
 s	|int	|fd_on_nosuid_fs|int fd
 #  endif
diff --git a/embed.h b/embed.h
index 6eefaae1f9..674f8a1058 100644
--- a/embed.h
+++ b/embed.h
@@ -2530,7 +2530,7 @@
 #define mod(a,b)		Perl_mod(aTHX_ a,b)
 #define mode_from_discipline(a)	Perl_mode_from_discipline(aTHX_ a)
 #endif
-#define moreswitches(a)		Perl_moreswitches(aTHX_ a)
+#define moreswitches(a,b)	Perl_moreswitches(aTHX_ a,b)
 #ifdef PERL_CORE
 #define my(a)			Perl_my(aTHX_ a)
 #endif
@@ -3188,8 +3188,8 @@
 #endif
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
-#define find_beginning()	S_find_beginning(aTHX)
-#define forbid_setid(a)		S_forbid_setid(aTHX_ a)
+#define find_beginning(a)	S_find_beginning(aTHX_ a)
+#define forbid_setid(a,b)	S_forbid_setid(aTHX_ a,b)
 #define incpush(a,b,c,d,e)	S_incpush(aTHX_ a,b,c,d,e)
 #define init_interp()		S_init_interp(aTHX)
 #define init_ids()		S_init_ids(aTHX)
@@ -3200,9 +3200,9 @@
 #define init_predump_symbols()	S_init_predump_symbols(aTHX)
 #define my_exit_jump()		S_my_exit_jump(aTHX)
 #define nuke_stacks()		S_nuke_stacks(aTHX)
-#define open_script(a,b,c)	S_open_script(aTHX_ a,b,c)
+#define open_script(a,b,c,d)	S_open_script(aTHX_ a,b,c,d)
 #define usage(a)		S_usage(aTHX_ a)
-#define validate_suid(a,b,c)	S_validate_suid(aTHX_ a,b,c)
+#define validate_suid(a,b,c,d)	S_validate_suid(aTHX_ a,b,c,d)
 #endif
 #  if defined(IAMSUID)
 #ifdef PERL_CORE
diff --git a/embedvar.h b/embedvar.h
index ecc46a009a..f2e09eb963 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -393,7 +393,6 @@
 #define PL_sublex_info		(vTHX->Isublex_info)
 #define PL_subline		(vTHX->Isubline)
 #define PL_subname		(vTHX->Isubname)
-#define PL_suidscript		(vTHX->Isuidscript)
 #define PL_sv_arenaroot		(vTHX->Isv_arenaroot)
 #define PL_sv_count		(vTHX->Isv_count)
 #define PL_sv_no		(vTHX->Isv_no)
@@ -674,7 +673,6 @@
 #define PL_Isublex_info		PL_sublex_info
 #define PL_Isubline		PL_subline
 #define PL_Isubname		PL_subname
-#define PL_Isuidscript		PL_suidscript
 #define PL_Isv_arenaroot	PL_sv_arenaroot
 #define PL_Isv_count		PL_sv_count
 #define PL_Isv_no		PL_sv_no
diff --git a/intrpvar.h b/intrpvar.h
index 90f5514418..dc5868a1e8 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -515,10 +515,6 @@ PERLVARI(Irehash_seed, UV, 0)		/* 582 hash initializer */
 
 PERLVARI(Irehash_seed_set, bool, FALSE)	/* 582 hash initialized? */
 
-/* These two variables are needed to preserve 5.8.x bincompat because we can't
-   change function prototypes of two exported functions.  Probably should be
-   taken out of blead soon, and relevant prototypes changed.  */
-PERLVARI(Isuidscript, int, -1)	/* fd for suid script */
 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 /* File descriptor to talk to the child which dumps scalars.  */
 PERLVARI(Idumper_fd, int, -1)
diff --git a/perl.c b/perl.c
index 24f06f0d67..5f9b99b92c 100644
--- a/perl.c
+++ b/perl.c
@@ -1594,8 +1594,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     bool minus_f = FALSE;
 #endif
     int fdscript;
+    int suidscript;
 
-    PL_suidscript = -1;
     sv_setpvn(PL_linestr,"",0);
     sv = newSVpvs("");		/* first used for -I flags */
     SAVEFREESV(sv);
@@ -1645,7 +1645,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	case 'X':
 	case 'w':
 	case 'A':
-	    if ((s = moreswitches(s)))
+	    if ((s = moreswitches(s, suidscript)))
 		goto reswitch;
 	    break;
 
@@ -1673,7 +1673,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	    if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
 		break;
 #endif
-	    forbid_setid('e');
+	    forbid_setid('e', suidscript);
 	    if (!PL_e_script) {
 		PL_e_script = newSVpvs("");
 		filter_add(read_e_script, NULL);
@@ -1697,7 +1697,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	    goto reswitch;
 
 	case 'I':	/* -I handled both here and in moreswitches() */
-	    forbid_setid('I');
+	    forbid_setid('I', suidscript);
 	    if (!*++s && (s=argv[1]) != NULL) {
 		argc--,argv++;
 	    }
@@ -1714,12 +1714,12 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 		Perl_croak(aTHX_ "No directory specified for -I");
 	    break;
 	case 'P':
-	    forbid_setid('P');
+	    forbid_setid('P', suidscript);
 	    PL_preprocess = TRUE;
 	    s++;
 	    goto reswitch;
 	case 'S':
-	    forbid_setid('S');
+	    forbid_setid('S', suidscript);
 	    dosearch = TRUE;
 	    s++;
 	    goto reswitch;
@@ -1983,7 +1983,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 		        PL_tainting = TRUE;
 		    }
 		} else {
-		    moreswitches(d);
+		    moreswitches(d, suidscript);
 		}
 	    }
 	}
@@ -2011,7 +2011,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     else if (scriptname == NULL) {
 #ifdef MSDOS
 	if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
-	    moreswitches("h");
+	    moreswitches("h", suidscript);
 #endif
 	scriptname = "-";
     }
@@ -2023,9 +2023,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     TAINT_NOT;
     init_perllib();
 
-    fdscript = open_script(scriptname,dosearch,sv);
+    fdscript = open_script(scriptname, dosearch, sv, &suidscript);
 
-    validate_suid(validarg, scriptname, fdscript);
+    validate_suid(validarg, scriptname, fdscript, suidscript);
 
 #ifndef PERL_MICRO
 #if defined(SIGCHLD) || defined(SIGCLD)
@@ -2049,7 +2049,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #else
     if (PL_doextract) {
 #endif
-	find_beginning();
+	find_beginning(suidscript);
 	if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
 	    Perl_croak(aTHX_ "Can't chdir to %s",cddir);
 
@@ -2934,7 +2934,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
 /* This routine handles any switches that can be given during run */
 
 char *
-Perl_moreswitches(pTHX_ char *s)
+Perl_moreswitches(pTHX_ char *s, const int suidscript)
 {
     dVAR;
     UV rschar;
@@ -3002,7 +3002,7 @@ Perl_moreswitches(pTHX_ char *s)
 	s++;
 	return s;
     case 'd':
-	forbid_setid('d');
+	forbid_setid('d', suidscript);
 	s++;
 
         /* -dt indicates to the debugger that threads will be used */
@@ -3036,7 +3036,7 @@ Perl_moreswitches(pTHX_ char *s)
     case 'D':
     {	
 #ifdef DEBUGGING
-	forbid_setid('D');
+	forbid_setid('D', suidscript);
 	s++;
 	PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
 #else /* !DEBUGGING */
@@ -3068,7 +3068,7 @@ Perl_moreswitches(pTHX_ char *s)
 	}
 	return s;
     case 'I':	/* -I handled both here and in parse_body() */
-	forbid_setid('I');
+	forbid_setid('I', suidscript);
 	++s;
 	while (*s && isSPACE(*s))
 	    ++s;
@@ -3117,7 +3117,7 @@ Perl_moreswitches(pTHX_ char *s)
 	}
 	return s;
     case 'A':
-	forbid_setid('A');
+	forbid_setid('A', suidscript);
 	if (!PL_preambleav)
 	    PL_preambleav = newAV();
 	s++;
@@ -3140,10 +3140,10 @@ Perl_moreswitches(pTHX_ char *s)
 	    return s;
 	}
     case 'M':
-	forbid_setid('M');	/* XXX ? */
+	forbid_setid('M', suidscript);	/* XXX ? */
 	/* FALL THROUGH */
     case 'm':
-	forbid_setid('m');	/* XXX ? */
+	forbid_setid('m', suidscript);	/* XXX ? */
 	if (*++s) {
 	    char *start;
 	    SV *sv;
@@ -3190,7 +3190,7 @@ Perl_moreswitches(pTHX_ char *s)
 	s++;
 	return s;
     case 's':
-	forbid_setid('s');
+	forbid_setid('s', suidscript);
 	PL_doswitches = TRUE;
 	s++;
 	return s;
@@ -3501,7 +3501,8 @@ S_init_main_stash(pTHX)
 
 /* PSz 18 Nov 03  fdscript now global but do not change prototype */
 STATIC int
-S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
+S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
+	      int *suidscript)
 {
 #ifndef IAMSUID
     const char *quote;
@@ -3512,7 +3513,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
     int fdscript = -1;
     dVAR;
 
-    PL_suidscript = -1;
+    *suidscript = -1;
 
     if (PL_e_script) {
 	PL_origfilename = savepvs("-e");
@@ -3536,7 +3537,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
 		 * Is it a mistake to use a similar /dev/fd/ construct for
 		 * suidperl?
 		 */
-		PL_suidscript = 1;
+		*suidscript = 1;
 		/* PSz 20 Feb 04  
 		 * Be supersafe and do some sanity-checks.
 		 * Still, can we be sure we got the right thing?
@@ -3579,7 +3580,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
  * perl with that fd as it has always done.
  */
     }
-    if (PL_suidscript != 1) {
+    if (*suidscript != 1) {
 	Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
     }
 #else /* IAMSUID */
@@ -3650,7 +3651,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
 	SvREFCNT_dec(cpp);
     }
     else if (!*scriptname) {
-	forbid_setid(0);
+	forbid_setid(0, *suidscript);
 	PL_rsfp = PerlIO_stdin();
     }
     else {
@@ -3809,7 +3810,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
 
 STATIC void
 S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
-		int fdscript)
+		int fdscript, int suidscript)
 {
     dVAR;
 #ifdef IAMSUID
@@ -3854,7 +3855,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
 	const char *s_end;
 
 #ifdef IAMSUID
-	if (fdscript < 0 || PL_suidscript != 1)
+	if (fdscript < 0 || suidscript != 1)
 	    Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");	/* We already checked this */
 	/* PSz 11 Nov 03
 	 * Since the script is opened by perl, not suidperl, some of these
@@ -4133,7 +4134,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 #ifdef IAMSUID
     else if (PL_preprocess)	/* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
 	Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
-    else if (fdscript < 0 || PL_suidscript != 1)
+    else if (fdscript < 0 || suidscript != 1)
 	/* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
 	Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
     else {
@@ -4216,7 +4217,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 }
 
 STATIC void
-S_find_beginning(pTHX)
+S_find_beginning(pTHX_ const int suidscript)
 {
     dVAR;
     register char *s;
@@ -4227,7 +4228,7 @@ S_find_beginning(pTHX)
 
     /* skip forward in input to the real script? */
 
-    forbid_setid('x');
+    forbid_setid('x', suidscript);
 #ifdef MACOS_TRADITIONAL
     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
 
@@ -4263,7 +4264,7 @@ S_find_beginning(pTHX)
 		while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
 		       || s2[-1] == '_') s2--;
 		if (strnEQ(s2-4,"perl",4))
-		    while ((s = moreswitches(s)))
+		    while ((s = moreswitches(s, suidscript)))
 			;
 	    }
 #ifdef MACOS_TRADITIONAL
@@ -4353,7 +4354,7 @@ Perl_doing_taint(int argc, char *argv[], char *envp[])
    "program input from stdin", which is substituted in place of '\0', which
    could never be a command line flag.  */
 STATIC void
-S_forbid_setid(pTHX_ const char flag)
+S_forbid_setid(pTHX_ const char flag, const int suidscript)
 {
     dVAR;
     char string[3] = "-x";
@@ -4392,7 +4393,7 @@ S_forbid_setid(pTHX_ const char flag)
      * 
      * Also see comments about root running a setuid script, elsewhere.
      */
-    if (PL_suidscript >= 0)
+    if (suidscript >= 0)
         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
 #ifdef IAMSUID
     /* PSz 11 Nov 03  Catch it in suidperl, always! */
diff --git a/perlapi.h b/perlapi.h
index 17cbf69c7b..ad1a2efc08 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -584,8 +584,6 @@ END_EXTERN_C
 #define PL_subline		(*Perl_Isubline_ptr(aTHX))
 #undef  PL_subname
 #define PL_subname		(*Perl_Isubname_ptr(aTHX))
-#undef  PL_suidscript
-#define PL_suidscript		(*Perl_Isuidscript_ptr(aTHX))
 #undef  PL_sv_arenaroot
 #define PL_sv_arenaroot		(*Perl_Isv_arenaroot_ptr(aTHX))
 #undef  PL_sv_count
diff --git a/proto.h b/proto.h
index bf28fc82e3..be01dc4530 100644
--- a/proto.h
+++ b/proto.h
@@ -1306,7 +1306,7 @@ PERL_CALLCONV void	Perl_mini_mktime(pTHX_ struct tm *pm)
 
 PERL_CALLCONV OP*	Perl_mod(pTHX_ OP* o, I32 type);
 PERL_CALLCONV int	Perl_mode_from_discipline(pTHX_ SV* discp);
-PERL_CALLCONV char*	Perl_moreswitches(pTHX_ char* s)
+PERL_CALLCONV char*	Perl_moreswitches(pTHX_ char* s, int suidscript)
 			__attribute__nonnull__(pTHX_1);
 
 PERL_CALLCONV OP*	Perl_my(pTHX_ OP* o)
@@ -3167,8 +3167,8 @@ PERL_CALLCONV void	Perl_Slab_Free(pTHX_ void *op)
 #endif
 
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
-STATIC void	S_find_beginning(pTHX);
-STATIC void	S_forbid_setid(pTHX_ char flag);
+STATIC void	S_find_beginning(pTHX_ int suidscript);
+STATIC void	S_forbid_setid(pTHX_ char flag, int suidscript);
 STATIC void	S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, bool canrelocate);
 STATIC void	S_init_interp(pTHX);
 STATIC void	S_init_ids(pTHX);
@@ -3183,14 +3183,15 @@ STATIC void	S_my_exit_jump(pTHX)
 			__attribute__noreturn__;
 
 STATIC void	S_nuke_stacks(pTHX);
-STATIC int	S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
+STATIC int	S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, int *suidscript)
 			__attribute__nonnull__(pTHX_1)
-			__attribute__nonnull__(pTHX_3);
+			__attribute__nonnull__(pTHX_3)
+			__attribute__nonnull__(pTHX_4);
 
 STATIC void	S_usage(pTHX_ const char *name)
 			__attribute__nonnull__(pTHX_1);
 
-STATIC void	S_validate_suid(pTHX_ const char *validarg, const char *scriptname, int fdscript)
+STATIC void	S_validate_suid(pTHX_ const char *validarg, const char *scriptname, int fdscript, int suidscript)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
 
diff --git a/toke.c b/toke.c
index 8f01720491..df89130abe 100644
--- a/toke.c
+++ b/toke.c
@@ -3008,7 +3008,12 @@ Perl_yylex(pTHX)
 				Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
 				      (int)(d - m), m);
 			    }
-			    d = moreswitches(d);
+			    /* Given that these switches are within the script,
+			       then it is not unsafe to allow them even within
+			       a suidperl fd script. Hence pass in the
+			       suidscript flag as -1, irrespective of what we
+			       really are.  */
+			    d = moreswitches(d, -1);
 			} while (d);
 			if (PL_doswitches && !switches_done) {
 			    int argc = PL_origargc;