Eliminating PL_suidscript is more tricky, and requires changing the

prototype of Perl_moreswitches.

p4raw-id: //depot/perl@27070

diff --git a/embed.fnc b/embed.fnc
index 35edb4f..16d1d02 100644 (file)
--- 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 6eefaae..674f8a1 100644 (file)
--- 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 ecc46a0..f2e09eb 100644 (file)
--- 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 90f5514..dc5868a 100644 (file)
--- 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 24f06f0..5f9b99b 100644 (file)
--- 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 17cbf69..ad1a2ef 100644 (file)
--- 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 bf28fc8..be01dc4 100644 (file)
--- 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 8f01720..df89130 100644 (file)
--- 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;