- PERL_ARGS_ASSERT_VALIDATE_SUID;
-
- /* do we need to emulate setuid on scripts? */
-
- /* This code is for those BSD systems that have setuid #! scripts disabled
- * in the kernel because of a security problem. Merely defining DOSUID
- * in perl will not fix that problem, but if you have disabled setuid
- * scripts in the kernel, this will attempt to emulate setuid and setgid
- * on scripts that have those now-otherwise-useless bits set. The setuid
- * root version must be called suidperl or sperlN.NNN. If regular perl
- * discovers that it has opened a setuid script, it calls suidperl with
- * the same argv that it had. If suidperl finds that the script it has
- * just opened is NOT setuid root, it sets the effective uid back to the
- * uid. We don't just make perl setuid root because that loses the
- * effective uid we had before invoking perl, if it was different from the
- * uid.
- * PSz 27 Feb 04
- * Description/comments above do not match current workings:
- * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
- * suidperl called with script open and name changed to /dev/fd/N/X;
- * suidperl croaks if script is not setuid;
- * making perl setuid would be a huge security risk (and yes, that
- * would lose any euid we might have had).
- *
- * DOSUID must be defined in both perl and suidperl, and IAMSUID must
- * be defined in suidperl only. suidperl must be setuid root. The
- * Configure script will set this up for you if you want it.
- */
-
- if (PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
- Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
- if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
- I32 len;
- const char *linestr;
- const char *s_end;
-
-# ifdef IAMSUID
- if (fdscript < 0 || !suidscript)
- 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
- * checks are superfluous. Leaving them in probably does not lower
- * security(?!).
- */
- /* PSz 27 Feb 04
- * Do checks even for systems with no HAS_SETREUID.
- * We used to swap, then re-swap UIDs with
-# ifdef HAS_SETREUID
- if (setreuid(PL_euid,PL_uid) < 0
- || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
- Perl_croak(aTHX_ "Can't swap uid and euid");
-# endif
-# ifdef HAS_SETREUID
- if (setreuid(PL_uid,PL_euid) < 0
- || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
- Perl_croak(aTHX_ "Can't reswap uid and euid");
-# endif
- */
-
- /* On this access check to make sure the directories are readable,
- * there is actually a small window that the user could use to make
- * filename point to an accessible directory. So there is a faint
- * chance that someone could execute a setuid script down in a
- * non-accessible directory. I don't know what to do about that.
- * But I don't think it's too important. The manual lies when
- * it says access() is useful in setuid programs.
- *
- * So, access() is pretty useless... but not harmful... do anyway.
- */
- if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
- Perl_croak(aTHX_ "Can't access() script\n");
- }
-
- /* If we can swap euid and uid, then we can determine access rights
- * with a simple stat of the file, and then compare device and
- * inode to make sure we did stat() on the same file we opened.
- * Then we just have to make sure he or she can execute it.
- *
- * PSz 24 Feb 04
- * As the script is opened by perl, not suidperl, we do not need to
- * care much about access rights.
- *
- * The 'script changed' check is needed, or we can get lied to
- * about $0 with e.g.
- * suidperl /dev/fd/4//bin/x 4<setuidscript
- * Without HAS_SETREUID, is it safe to stat() as root?
- *
- * Are there any operating systems that pass /dev/fd/xxx for setuid
- * scripts, as suggested/described in perlsec(1)? Surely they do not
- * pass the script name as we do, so the "script changed" test would
- * fail for them... but we never get here with
- * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
- *
- * This is one place where we must "lie" about return status: not
- * say if the stat() failed. We are doing this as root, and could
- * be tricked into reporting existence or not of files that the
- * "plain" user cannot even see.
- */
- {
- Stat_t tmpstatbuf;
- if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
- tmpstatbuf.st_dev != PL_statbuf.st_dev ||
- tmpstatbuf.st_ino != PL_statbuf.st_ino) {
- Perl_croak(aTHX_ "Setuid script changed\n");
- }
-
- }
- if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
- Perl_croak(aTHX_ "Real UID cannot exec script\n");
-
- /* PSz 27 Feb 04
- * We used to do this check as the "plain" user (after swapping
- * UIDs). But the check for nosuid and noexec filesystem is needed,
- * and should be done even without HAS_SETREUID. (Maybe those
- * operating systems do not have such mount options anyway...)
- * Seems safe enough to do as root.
- */
-# if !defined(NO_NOSUID_CHECK)
- if (fd_on_nosuid_fs(PerlIO_fileno(rsfp))) {
- Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
- }
-# endif
-# endif /* IAMSUID */
-
- if (!S_ISREG(PL_statbuf.st_mode)) {
- Perl_croak(aTHX_ "Setuid script not plain file\n");
- }
- if (PL_statbuf.st_mode & S_IWOTH)
- Perl_croak(aTHX_ "Setuid/gid script is writable by world");
- PL_doswitches = FALSE; /* -s is insecure in suid */
- /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
- CopLINE_inc(PL_curcop);
- if (sv_gets(linestr_sv, rsfp, 0) == NULL)
- Perl_croak(aTHX_ "No #! line");
- linestr = SvPV_nolen_const(linestr_sv);
- /* required even on Sys V */
- if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
- Perl_croak(aTHX_ "No #! line");
- linestr += 2;
- s = linestr;
- /* PSz 27 Feb 04 */
- /* Sanity check on line length */
- s_end = s + strlen(s);
- if (s_end == s || (s_end - s) > 4000)
- Perl_croak(aTHX_ "Very long #! line");
- /* Allow more than a single space after #! */
- while (isSPACE(*s)) s++;
- /* Sanity check on buffer end */
- while ((*s) && !isSPACE(*s)) s++;
- for (s2 = s; (s2 > linestr &&
- (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
- || s2[-1] == '-')); s2--) ;
- /* Sanity check on buffer start */
- if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
- (s-9 < linestr || strnNE(s-9,"perl",4)) )
- Perl_croak(aTHX_ "Not a perl script");
- while (*s == ' ' || *s == '\t') s++;
- /*
- * #! arg must be what we saw above. They can invoke it by
- * mentioning suidperl explicitly, but they may not add any strange
- * arguments beyond what #! says if they do invoke suidperl that way.
- */
- /*
- * The way validarg was set up, we rely on the kernel to start
- * scripts with argv[1] set to contain all #! line switches (the
- * whole line).
- */
- /*
- * Check that we got all the arguments listed in the #! line (not
- * just that there are no extraneous arguments). Might not matter
- * much, as switches from #! line seem to be acted upon (also), and
- * so may be checked and trapped in perl. But, security checks must
- * be done in suidperl and not deferred to perl. Note that suidperl
- * does not get around to parsing (and checking) the switches on
- * the #! line (but execs perl sooner).
- * Allow (require) a trailing newline (which may be of two
- * characters on some architectures?) (but no other trailing
- * whitespace).
- */
- len = strlen(validarg);
- if (strEQ(validarg," PHOOEY ") ||
- strnNE(s,validarg,len) || !isSPACE(s[len]) ||
- !((s_end - s) == len+1
- || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
- Perl_croak(aTHX_ "Args must match #! line");
-
-# ifndef IAMSUID
- if (fdscript < 0 &&
- PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
- PL_euid == PL_statbuf.st_uid)
- if (!PL_do_undump)
- Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
-FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
-# endif /* IAMSUID */
-
- if (fdscript < 0 &&
- PL_euid) { /* oops, we're not the setuid root perl */
- /* PSz 18 Feb 04
- * When root runs a setuid script, we do not go through the same
- * steps of execing sperl and then perl with fd scripts, but
- * simply set up UIDs within the same perl invocation; so do
- * not have the same checks (on options, whatever) that we have
- * for plain users. No problem really: would have to be a script
- * that does not actually work for plain users; and if root is
- * foolish and can be persuaded to run such an unsafe script, he
- * might run also non-setuid ones, and deserves what he gets.
- *
- * Or, we might drop the PL_euid check above (and rely just on
- * fdscript to avoid loops), and do the execs
- * even for root.
- */
-# ifndef IAMSUID
- int which;
- /* PSz 11 Nov 03
- * Pass fd script to suidperl.
- * Exec suidperl, substituting fd script for scriptname.
- * Pass script name as "subdir" of fd, which perl will grok;
- * in fact will use that to distinguish this from "normal"
- * usage, see comments above.
- */
- PerlIO_rewind(rsfp);
- PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
- /* PSz 27 Feb 04 Sanity checks on scriptname */
- if ((!scriptname) || (!*scriptname) ) {
- Perl_croak(aTHX_ "No setuid script name\n");
- }
- if (*scriptname == '-') {
- Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
- /* Or we might confuse it with an option when replacing
- * name in argument list, below (though we do pointer, not
- * string, comparisons).
- */
- }
- for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
- if (!PL_origargv[which]) {
- Perl_croak(aTHX_ "Can't change argv to have fd script\n");
- }
- PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
- PerlIO_fileno(rsfp), PL_origargv[which]));
-# if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
-# endif
- PERL_FPU_PRE_EXEC
- PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
- (int)PERL_REVISION, (int)PERL_VERSION,
- (int)PERL_SUBVERSION), PL_origargv);
- PERL_FPU_POST_EXEC
-# endif /* IAMSUID */
- Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
- }
-
- if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
-/* PSz 26 Feb 04
- * This seems back to front: we try HAS_SETEGID first; if not available
- * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
- * in the sense that we only want to set EGID; but are there any machines
- * with either of the latter, but not the former? Same with UID, later.
- */
-# ifdef HAS_SETEGID
- (void)setegid(PL_statbuf.st_gid);
-# else
-# ifdef HAS_SETREGID
- (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
-# else
-# ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
-# else
- PerlProc_setgid(PL_statbuf.st_gid);
-# endif
-# endif
-# endif
- if (PerlProc_getegid() != PL_statbuf.st_gid)
- Perl_croak(aTHX_ "Can't do setegid!\n");
- }
- if (PL_statbuf.st_mode & S_ISUID) {
- if (PL_statbuf.st_uid != PL_euid)
-# ifdef HAS_SETEUID
- (void)seteuid(PL_statbuf.st_uid); /* all that for this */
-# else
-# ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
-# else
-# ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
-# else
- PerlProc_setuid(PL_statbuf.st_uid);
-# endif
-# endif
-# endif
- if (PerlProc_geteuid() != PL_statbuf.st_uid)
- Perl_croak(aTHX_ "Can't do seteuid!\n");
- }
- else if (PL_uid) { /* oops, mustn't run as root */
-# ifdef HAS_SETEUID
- (void)seteuid((Uid_t)PL_uid);
-# else
-# ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
-# else
-# ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
-# else
- PerlProc_setuid((Uid_t)PL_uid);
-# endif
-# endif
-# endif
- if (PerlProc_geteuid() != PL_uid)
- Perl_croak(aTHX_ "Can't do seteuid!\n");
- }
- init_ids();
- if (!cando(S_IXUSR,TRUE,&PL_statbuf))
- Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
- }
-# ifdef IAMSUID
- else if (fdscript < 0 || !suidscript)
- /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
- Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
- else {
-/* PSz 16 Sep 03 Keep neat error message */
- Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
- }
-
- /* We absolutely must clear out any saved ids here, so we */
- /* exec the real perl, substituting fd script for scriptname. */
- /* (We pass script name as "subdir" of fd, which perl will grok.) */
- /*
- * It might be thought that using setresgid and/or setresuid (changed to
- * set the saved IDs) above might obviate the need to exec, and we could
- * go on to "do the perl thing".
- *
- * Is there such a thing as "saved GID", and is that set for setuid (but
- * not setgid) execution like suidperl? Without exec, it would not be
- * cleared for setuid (but not setgid) scripts (or might need a dummy
- * setresgid).
- *
- * We need suidperl to do the exact same argument checking that perl
- * does. Thus it cannot be very small; while it could be significantly
- * smaller, it is safer (simpler?) to make it essentially the same
- * binary as perl (but they are not identical). - Maybe could defer that
- * check to the invoked perl, and suidperl be a tiny wrapper instead;
- * but prefer to do thorough checks in suidperl itself. Such deferral
- * would make suidperl security rely on perl, a design no-no.
- *
- * Setuid things should be short and simple, thus easy to understand and
- * verify. They should do their "own thing", without influence by
- * attackers. It may help if their internal execution flow is fixed,
- * regardless of platform: it may be best to exec anyway.
- *
- * Suidperl should at least be conceptually simple: a wrapper only,
- * never to do any real perl. Maybe we should put
- * #ifdef IAMSUID
- * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
- * #endif
- * into the perly bits.
- */
- PerlIO_rewind(rsfp);
- PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
- /* PSz 11 Nov 03
- * Keep original arguments: suidperl already has fd script.
- */
-# if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
-# endif
- PERL_FPU_PRE_EXEC
- PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
- (int)PERL_REVISION, (int)PERL_VERSION,
- (int)PERL_SUBVERSION), PL_origargv);/* try again */
- PERL_FPU_POST_EXEC
- Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
-# endif /* IAMSUID */
-}
-
-#else /* !DOSUID */
-
-# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW