In perl.git, the branch smoke-me/kick-FAKE_BIT_BUCKET has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3ea1fc5156d287c1946f337eedc80efd2ccbb842?hp=4764fecd41019d910c6e71de9d5b1a15c66dfa30>
- Log ----------------------------------------------------------------- commit 3ea1fc5156d287c1946f337eedc80efd2ccbb842 Author: Nicholas Clark <[email protected]> Date: Mon Feb 27 15:21:38 2012 +0100 In perl.c, only compile S_forbid_setid() if it's needed. If SETUID_SCRIPTS_ARE_SECURE_NOW is defined, S_forbid_setid() is a no-op, so don't compile it. Move the declaration and definition of S_forbid_setid() into the same pre-processor blocks as are used for S_validate_suid(), which is a no-op when SETUID_SCRIPTS_ARE_SECURE_NOW is /not/ defined. M embed.fnc M embed.h M perl.c M proto.h commit 4b53f9ae30a19c4c0d18a058fa72ef71604db9ed Author: Nicholas Clark <[email protected]> Date: Mon Feb 27 14:53:24 2012 +0100 Inline the "program input from stdin" check into S_open_script(). This removes the special case code for this from S_forbid_setid(), leaving it dealing only with checking on -x options. For both locations, refactor the croak() logic to share the same message format string. M perl.c commit 696b903086f358078a4aa7300c3d1efa638e419c Author: Nicholas Clark <[email protected]> Date: Sun Feb 26 19:40:19 2012 +0100 Eliminate the suidscript parameter from S_forbid_setid() - it's always false. M embed.fnc M embed.h M perl.c M proto.h commit 514dd72c40e33d8e732a6549713a60c8eff1f536 Author: Nicholas Clark <[email protected]> Date: Sun Feb 26 17:22:17 2012 +0100 Pass doextract to S_open_script(), signaling whether -x is enabled. Inline the suidscript is true part of the forbid_setid() test for 'x' in the fdopen branch of S_open_script(). This means that for all callers of forbid_setid(), the parameter suidscript is false. M embed.fnc M embed.h M perl.c M proto.h commit d644d1cd445598f13ff6f13fa4d802a64238a085 Author: Nicholas Clark <[email protected]> Date: Sun Feb 26 16:50:25 2012 +0100 Normalise two error messages in S_open_script() to have trailing periods. All the other fatal errors generated by switch parsing and script opening don't pass a trailing "\n" to Perl_croak(), resulting in output with a trailing period. (And no filename or line number, as these are not set yet.) M perl.c M t/run/fdopen.t commit 637382f8ec7bc04ece4362d320eb6242942bcb03 Author: Nicholas Clark <[email protected]> Date: Sun Feb 26 16:34:00 2012 +0100 Add t/run/fdopen.t, which tests the /dev/fd/\d+ code for opening scripts. perl uses S_open_script() in perl.c to open the file handle on the Perl program. In 5.003 this was enhanced to parse filenames such as /dev/fd/3 (directly using fdopen() to open file descriptor 3), as part of a suidperl fix. It was subsequently further enhanced to permit $0 to be set by suffixing the /dev/fd/\d+ with the file name to use. Although suidperl was removed from the core by commit cc69b689ee7c2745 in Jan 2009, this code remained, as it's a useful feature for anyone wishing to maintain suidperl externally, or write an alternative secure wrapper system. M MANIFEST M pod/perldelta.pod A t/run/fdopen.t commit 50cfd03070efc8c21a6a0e9dc48705d295284d43 Author: Nicholas Clark <[email protected]> Date: Sun Feb 26 00:50:23 2012 +0100 In S_open_script(), avoid setting scriptname to "" to benefit one if() test. If PL_origfilename is "-" then scriptname was being set to "". However, the only thing then depending on the value of scriptname was an if() test 4 lines later. Hence simply augment that if test with the check for "-", avoiding the need for an assignment. M perl.c commit c2da634c7781686394a7568c7f313806790b79cb Author: Nicholas Clark <[email protected]> Date: Sun Feb 26 00:37:47 2012 +0100 Add 2 assertions to S_open_script(). If *suidscript is TRUE, then fdscript has to be >= 0; If we're defaulting to reading from stdin, then *suidscript has to be FALSE. Knowing that these both hold will permit simplification of the code. M perl.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + embed.fnc | 3 +- embed.h | 1 - perl.c | 119 +++++++++++++++++++++++++--------------------------- pod/perldelta.pod | 5 ++ proto.h | 8 +-- t/run/fdopen.t | 113 ++++++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 180 insertions(+), 70 deletions(-) create mode 100644 t/run/fdopen.t diff --git a/MANIFEST b/MANIFEST index fb33cec..c96a43c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5448,6 +5448,7 @@ t/re/uniprops.t Test unicode \p{} regex constructs t/run/cloexec.t Test close-on-exec. t/run/dtrace.t Test for DTrace probes t/run/exit.t Test perl's exit status. +t/run/fdopen.t Test the code that emulates /dev/fd/3 etc t/run/fresh_perl.t Tests that require a fresh perl. t/run/locale.t Tests related to locale handling t/run/noswitch.t Test aliasing ARGV for other switch tests diff --git a/embed.fnc b/embed.fnc index c549dc9..a73deb0 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1772,7 +1772,6 @@ s |void |Slab_to_rw |NN void *op #if defined(PERL_IN_PERL_C) s |void |find_beginning |NN SV* linestr_sv|NN PerlIO *rsfp -s |void |forbid_setid |const char flag|const bool suidscript s |void |incpush |NN const char *const dir|STRLEN len \ |U32 flags s |SV* |mayberelocate |NN const char *const dir|STRLEN len \ @@ -1787,7 +1786,7 @@ s |void |init_predump_symbols rs |void |my_exit_jump s |void |nuke_stacks s |PerlIO *|open_script |NN const char *scriptname|bool dosearch \ - |NN bool *suidscript + |bool doextract sr |void |usage #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW so |void |validate_suid |NN PerlIO *rsfp diff --git a/embed.h b/embed.h index 1d1e598..4e154c1 100644 --- a/embed.h +++ b/embed.h @@ -1429,7 +1429,6 @@ # endif # if defined(PERL_IN_PERL_C) #define find_beginning(a,b) S_find_beginning(aTHX_ a,b) -#define forbid_setid(a,b) S_forbid_setid(aTHX_ a,b) #define incpush(a,b,c) S_incpush(aTHX_ a,b,c) #define incpush_use_sep(a,b,c) S_incpush_use_sep(aTHX_ a,b,c) #define init_ids() S_init_ids(aTHX) diff --git a/perl.c b/perl.c index 104cac7..a9f380b 100644 --- a/perl.c +++ b/perl.c @@ -77,11 +77,13 @@ 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 +static void S_forbid_setid(pTHX_ const char flag); + +# define validate_suid(rsfp) NOOP +# define forbid_setid(flag) S_forbid_setid(aTHX_ flag) #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) +# define forbid_setid(flag) NOOP #endif #define CALL_BODY_SUB(myop) \ @@ -1801,15 +1803,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(); { @@ -1868,7 +1867,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_minus_E = TRUE; /* FALL THROUGH */ case 'e': - forbid_setid('e', FALSE); + forbid_setid('e'); if (!PL_e_script) { PL_e_script = newSVpvs(""); add_read_e_script = TRUE; @@ -1892,7 +1891,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; case 'I': /* -I handled both here and in moreswitches() */ - forbid_setid('I', FALSE); + forbid_setid('I'); if (!*++s && (s=argv[1]) != NULL) { argc--,argv++; } @@ -1904,7 +1903,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) Perl_croak(aTHX_ "No directory specified for -I"); break; case 'S': - forbid_setid('S', FALSE); + forbid_setid('S'); dosearch = TRUE; s++; goto reswitch; @@ -2072,16 +2071,13 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) init_perllib(); { - bool suidscript = FALSE; - - rsfp = open_script(scriptname, dosearch, &suidscript); + rsfp = open_script(scriptname, dosearch, doextract); 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) @@ -2100,12 +2096,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif if (doextract) { + forbid_setid('x'); - /* This will croak if suidscript is true, as -x cannot be used with - setuid scripts. */ - 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); @@ -2234,6 +2228,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif lex_start(linestr_sv, rsfp, lex_start_flags); + if(linestr_sv) + SvREFCNT_dec(linestr_sv); + PL_subname = newSVpvs("main"); if (add_read_e_script) @@ -3110,7 +3107,7 @@ Perl_moreswitches(pTHX_ const char *s) s++; return s; case 'd': - forbid_setid('d', FALSE); + forbid_setid('d'); s++; /* -dt indicates to the debugger that threads will be used */ @@ -3158,7 +3155,7 @@ Perl_moreswitches(pTHX_ const char *s) case 'D': { #ifdef DEBUGGING - forbid_setid('D', FALSE); + forbid_setid('D'); s++; PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ @@ -3193,7 +3190,7 @@ Perl_moreswitches(pTHX_ const char *s) } return s; case 'I': /* -I handled both here and in parse_body() */ - forbid_setid('I', FALSE); + forbid_setid('I'); ++s; while (*s && isSPACE(*s)) ++s; @@ -3241,10 +3238,10 @@ Perl_moreswitches(pTHX_ const char *s) } return s; case 'M': - forbid_setid('M', FALSE); /* XXX ? */ + forbid_setid('M'); /* XXX ? */ /* FALL THROUGH */ case 'm': - forbid_setid('m', FALSE); /* XXX ? */ + forbid_setid('m'); /* XXX ? */ if (*++s) { const char *start; const char *end; @@ -3304,7 +3301,7 @@ Perl_moreswitches(pTHX_ const char *s) s++; return s; case 's': - forbid_setid('s', FALSE); + forbid_setid('s'); PL_doswitches = TRUE; s++; return s; @@ -3620,7 +3617,7 @@ S_init_main_stash(pTHX) } STATIC PerlIO * -S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) +S_open_script(pTHX_ const char *scriptname, bool dosearch, bool doextract) { int fdscript = -1; PerlIO *rsfp = NULL; @@ -3650,33 +3647,45 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) * Is it a mistake to use a similar /dev/fd/ construct for * suidperl? */ - *suidscript = TRUE; + assert(fdscript >= 0); /* PSz 20 Feb 04 * Be supersafe and do some sanity-checks. * Still, can we be sure we got the right thing? */ if (*s != '/') { - Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); + Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"", s); } if (! *(s+1)) { - Perl_croak(aTHX_ "Missing (suid) fd script name\n"); + Perl_croak(aTHX_ "Missing (suid) fd script name"); } scriptname = savepv(s + 1); Safefree(PL_origfilename); PL_origfilename = (char *)scriptname; + if (doextract) { + /* This will croak, as -x is not permitted with setuid + scripts. */ + Perl_croak(aTHX_ "No -x allowed with (suid) fdscript"); + } } } } CopFILE_free(PL_curcop); CopFILE_set(PL_curcop, PL_origfilename); - if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') - scriptname = (char *)""; if (fdscript >= 0) { rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); } - else if (!*scriptname) { - forbid_setid(0, *suidscript); + else if (!*scriptname + || (*PL_origfilename == '-' && PL_origfilename[1] == '\0')) { +#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW + char what = 0; + if (PerlProc_getuid() != PerlProc_geteuid()) + what = 'u'; + else if (PerlProc_getgid() != PerlProc_getegid()) + what = 'g'; + if (what) + Perl_croak(aTHX_ "No program input from stdin allowed while running set%cid", what); +#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ return NULL; } else { @@ -3746,7 +3755,19 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW -/* Don't even need this function. */ +static void +S_forbid_setid(pTHX_ const char flag) +{ + dVAR; + char what = 0; + + if (PerlProc_getuid() != PerlProc_geteuid()) + what = 'u'; + else if (PerlProc_getgid() != PerlProc_getegid()) + what = 'g'; + if (what) + Perl_croak(aTHX_ "No -%c allowed while running set%cid", flag, what); +} #else STATIC void S_validate_suid(pTHX_ PerlIO *rsfp) @@ -3864,32 +3885,6 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) return 0; } -/* Passing the flag as a single char rather than a string is a slight space - optimisation. The only message that isn't /^-.$/ is - "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, const bool suidscript) /* g */ -{ - dVAR; - char string[3] = "-x"; - const char *message = "program input from stdin"; - - if (flag) { - string[1] = flag; - message = string; - } - -#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW - if (PerlProc_getuid() != PerlProc_geteuid()) - Perl_croak(aTHX_ "No %s allowed while running setuid", message); - if (PerlProc_getgid() != PerlProc_getegid()) - Perl_croak(aTHX_ "No %s allowed while running setgid", message); -#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ - if (suidscript) - Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message); -} - void Perl_init_dbargs(pTHX) { diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 3326e71..9957f06 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -248,6 +248,11 @@ the file handle that it opens. Previously, it had been leaking the file handle if it happened to have file descriptor 0, which would happen if C<require> was called (explicitly or implicitly) when C<STDIN> had been closed. +=item * + +F<t/run/fdopen.t> has been added, to test code that processes script names +such as C</dev/fd/3>. + =back =head1 Platform Support diff --git a/proto.h b/proto.h index b811e6b..c086bf8 100644 --- a/proto.h +++ b/proto.h @@ -5892,7 +5892,6 @@ STATIC void S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) #define PERL_ARGS_ASSERT_FIND_BEGINNING \ assert(linestr_sv); assert(rsfp) -STATIC void S_forbid_setid(pTHX_ const char flag, const bool suidscript); STATIC void S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INCPUSH \ @@ -5925,11 +5924,10 @@ STATIC void S_my_exit_jump(pTHX) __attribute__noreturn__; STATIC void S_nuke_stacks(pTHX); -STATIC PerlIO * S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_3); +STATIC PerlIO * S_open_script(pTHX_ const char *scriptname, bool dosearch, bool doextract) + __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OPEN_SCRIPT \ - assert(scriptname); assert(suidscript) + assert(scriptname) STATIC void* S_parse_body(pTHX_ char **env, XSINIT_t xsinit); STATIC void S_run_body(pTHX_ I32 oldscope) diff --git a/t/run/fdopen.t b/t/run/fdopen.t new file mode 100644 index 0000000..4e679a5 --- /dev/null +++ b/t/run/fdopen.t @@ -0,0 +1,113 @@ +#!perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; + skip_all_without_config('d_fork'); +} +use strict; + +my $perl = which_perl(); +watchdog(60); +$^F = 65536; + +$SIG{PIPE} = sub { + print "# Ignoring a SIGPIPE\n"; +}; + +sub one_pipe { + my ($stdin, @args) = @_; + pipe my $r, my $w or die "pipe: $!"; + + my $pid = fork; + die "fork: $!" unless defined $pid; + + unless ($pid) { + # child + open STDIN, '<&', $r or die "reopen: $!"; + # Has to be a die, as we're in the child: + my $fileno = fileno STDIN; + die "fileno STDIN is $fileno" unless defined $fileno && $fileno == 0; + close $w or die "close: $!"; + exec $perl, @args; + die "exec: $!"; + } + + close $r or die "close: $!"; + print $w $stdin; + close $w or die "close: $!"; + + waitpid $pid, 0; +} + +one_pipe(qq{print "ok 1 - simple OK\\n"}); +one_pipe(qq{print "not ok 2 - should not read stdin\\n"}, + '-eprint "ok 2 - -e is honoured\n"'); +one_pipe(qq{print "ok 3 - fd open\\n"}, '/dev/fd/0'); +# This one exploits knowledge of the implementation to be sure which code is +# being run. I don't think that we should rely on it being atoi() internally. +one_pipe(qq{print "ok 4 - *our* fd open\\n"}, '/dev/fd/00'); +one_pipe(<<'EOP', '-x', '/dev/fd/00'); +print "not ok 5 - -x didn't work\n"; +die; +#!perl +print "ok 5 - -x worked\n"; +EOP + +{ + pipe my $r, my $w or die "pipe: $!"; + pipe my $r2, my $w2 or die "pipe: $!"; + + my $pid = fork; + die "fork: $!" unless defined $pid; + + unless ($pid) { + # child + open STDIN, '<&', $r or die "reopen: $!"; + # Has to be a die, as we're in the child: + my $fileno = fileno STDIN; + die "fileno STDIN is $fileno" unless defined $fileno && $fileno == 0; + $fileno = fileno $r2; + die "fileno \$r2 is $fileno" unless defined $fileno; + close $w or die "close: $!"; + close $w2 or die "close: $!"; + exec $perl, "/dev/fd/$fileno"; + die "exec: $!"; + } + + close $r or die "close: $!"; + close $r2 or die "close: $!"; + print $w qq{print "not ok 6 - you shouldn't see this\n"}; + close $w or die "close: $!"; + print $w2 qq{print "ok 6 - read from the correct file descriptor\\n"}; + close $w2 or die "close: $!"; + + waitpid $pid, 0; +} + +{ + my $pathname = 'whamm/glipp/klonk'; + one_pipe(qq{print \$0 eq '$pathname' ? "ok 7 - pathname set\\n" : "not ok 7 - pathname was '$0'\n"}, + "/dev/fd/0/$pathname"); +} + +curr_test(8); + +like(runperl(progfile => '/dev/fd/-1', stderr => 1), + qr!^Can't open perl script "/dev/fd/-1": !, + "Can't open a negative file handle"); + +like(runperl(progfile => '/dev/fd/0/', stderr => 1), + qr/\AMissing \(suid\) fd script name\.\r?\n/, + "Missing suid script name error"); + +like(runperl(progfile => '/dev/fd/0swoosh', stderr => 1), + qr/\AWrong syntax \(suid\) fd script name "swoosh"\.\r?\n/, + "Wrong suid script name error"); + +like(runperl(progfile => '/dev/fd/0/a', stderr => 1, switches => ['-x']), + qr/\ANo -x allowed with \(suid\) fdscript\.\r?\n/, + 'No -x allowed with suid fdscript'); + +done_testing(); -- Perl5 Master Repository
