#!/usr/bin/perl

# Usage:
#   To fix one or more specific suidperl executables in, say, /usr/bin:
#	cd /usr/bin
#	fixsperl sperl?.???
#   or, to check all $PATH directories for sperl?.??? and fix them, just say:
#	fixsperl
#   or just pipe the article containing this script to "perl -x" for
#   a similar effect.
#
#   If this fails, you may need to tweak one or more of the four customization
#   variables below.  The default values are just good guesses.

# Customization.

# Pick a C compiler.  Other possibilities are "gcc", "acc", "lcc", etc.
$CC = "cc";

# Pick an unused directory.  This will be created automatically.
$SUIDTMP = "/usr/suidtmp";

# Pick first one of setresuid, setreuid, seteuid, setuid that libc has.
$SETUID = "setreuid";

# Pick first one of setresgid, setregid, setegid, setgid that libc has.
$SETGID = "setregid";

# End of Customization.

# Do some sanity checks first.

if ($>) { die "You must run fixsperl as root\n"; }

$HASUID = "-DHAS_$SETUID";
$HASUID =~ tr/a-z/A-Z/;

$HASGID = "-DHAS_$SETGID";
$HASGID =~ tr/a-z/A-Z/;

umask(0077);		# Keep it all private by default.

# Copy the new suidperl code out to where cc can see it in $SUIDTMP.

sub make_suidtmp {
    -d $SUIDTMP || system "mkdir -p $SUIDTMP";
    -d $SUIDTMP || die "Could't create $SUIDTMP\n";
    -o $SUIDTMP || die "root doesn't own $SUIDTMP\n";
    chmod 0755, $SUIDTMP;

    open(CODE, ">$SUIDTMP/sperl.c") || die "Can't write $SUIDTMP/sperl.c: $!\n";
    while (<DATA>) {
	last if /END OF CODE/;
	print CODE;
    }
    close CODE;
    $made_suidtmp++;
}

# Look down the current PATH for instances of suidperl.

if (!@ARGV) {
    # Round up the likely suspects.
    @dirs = grep(!$seen{$_}++, split(/:/, $ENV{'PATH'}),
	"/bin",
	"/usr/bin",
	"/usr/local",
	</*/bin /usr/*/bin>);

    foreach $dir (@dirs) {
	next if $dir eq "." || $dir eq "";
	next unless -d $dir;
	push(@ARGV, $dir);
    }
}

# Translate each directory to its contained suidperl files, if any.

@filelist = ();
foreach $name (@ARGV) {
    if (-d $name) {
	print "Looking in $name\n";
	push(@filelist, <$name/sperl[45].0?? $name/suidperl>);
    }
    else {
	push(@filelist, $name);
    }
}

# Try to fix each file found.  In any case, disable the old suidperl.
# (We don't check for the setuid bit because you may have already removed it.)

foreach $sperl (grep(-o $_, @filelist)) {
    print "Fixing $sperl\n";

    &make_suidtmp() unless $made_suidtmp;

    chmod 0600, $sperl;		# Disable old suidperl.
    rename($sperl, "$sperl.bad");

    # Find something to run as taintperl.  (Perl 5 uses normal perl for that.)
    $tperl = $sperl;
    $tperl =~ s#/sperl5#/perl5#;
    $tperl =~ s#/sperl4#/tperl4#;
    $tperl =~ s#/suidperl#/taintperl#;		# ancient
    $tperl =~ s#(.*)/.*#$1/perl# unless -f $tperl;
    $tperl = "/usr/bin/perl" unless -f $tperl;

    $defs = qq($HASUID $HASGID -DTAINTPERL='"$tperl"');
    $cmd = "$CC $defs -o $sperl $SUIDTMP/sperl.c";
    warn "\t$cmd\n";
    system $cmd;
    if ($?) {
	warn "FAILED--try changing one of the customization constants\n";
	rename("$sperl.bad", $sperl);
    }
    else {
	chmod 04711, $sperl;
    }
}
die "Nothing to fix" unless $made_suidtmp;
unlink "$SUIDTMP/sperl.c";

# Following is the C program that the script compiles to replace suidperl.
# POSIX.1 capabilities are assumed.  (If you don't have POSIX.1, you probably
# don't need this fix anyway.)
__END__
#ifndef TAINTPERL
#include "please define TAINTPERL"
#endif

#ifndef HAS_SETUID
#ifndef HAS_SETEUID
#ifndef HAS_SETREUID
#ifndef HAS_SETRESUID
#include "please define HAS_SETUID, HAS_SETEUID, HAS_SETREUID, or HAS_SETRESUID"
#endif
#endif
#endif
#endif

#ifndef HAS_SETGID
#ifndef HAS_SETEGID
#ifndef HAS_SETREGID
#ifndef HAS_SETRESGID
#include "please define HAS_SETGID, HAS_SETEGID, HAS_SETREGID, or HAS_SETRESGID"
#endif
#endif
#endif
#endif

#include <stdio.h>
#include <sys/stat.h>
#include <errno.h>
#include <string.h>
#include <ctype.h>

#ifndef SAFEDIR
#define SAFEDIR "/usr/suidtmp"
#endif

uid_t uid;
gid_t gid;
uid_t euid;
gid_t egid;

long
ingroup(testgid,effective)
long testgid;
long effective;
{
    if (testgid == (effective ? egid : gid))
	return 1;
#ifndef NGROUPS
#define NGROUPS 32
#endif
    {
	gid_t gary[NGROUPS];
	long anum;

	anum = getgroups(NGROUPS,gary);
	while (--anum >= 0)
	    if (gary[anum] == testgid)
		return 1;
    }
    return 0;
}

long
cando(bit, effective, statbufp)
long bit;
long effective;
struct stat *statbufp;
{
    if ((effective ? euid : uid) == 0) {	/* root is special */
	if (bit == S_IXUSR) {
	    if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
		return 1;
	}
	else
	    return 1;		/* root reads and writes anything */
	return 0;
    }
    if (statbufp->st_uid == (effective ? euid : uid) ) {
	if (statbufp->st_mode & bit)
	    return 1;	/* ok as "user" */
    }
    else if (ingroup((long)statbufp->st_gid,effective)) {
	if (statbufp->st_mode & bit >> 3)
	    return 1;	/* ok as "group" */
    }
    else if (statbufp->st_mode & bit >> 6)
	return 1;	/* ok as "other" */
    return 0;
}

int
main(argc,argv)
int argc;
char **argv;
{
    char **newargv = (char**)malloc((argc + 5) * sizeof(char*));
    int childpid;
    int saveumask;

    int old;
    int new;

    FILE *oldfp;
    FILE *newfp;

    char *oldscript = "script";
    char newscript[1024];

    struct stat statbuf;
    char *perlname;
    char realperl[1024];
    char buf[8192];
    long line = 0;
    char *validarg = "";
    char *s;

    uid = getuid();
    gid = getgid();
    euid = geteuid();
    egid = getegid();

    /* Out of memory already?  Yow! */

    if (!newargv) {
	fprintf(stderr, "Out of memory\n");
	goto oops;
    }

    /* Do some sanity checking on SAFEDIR. */

    /* exists? */
    if (stat(SAFEDIR, &statbuf)) {
	fprintf(stderr, "Can't stat %s, errno = %d\n", SAFEDIR, errno);
	exit(1);
    }

    /* owned by root? */
    if (statbuf.st_uid) {
	fprintf(stderr, "%s doesn't belong to root\n", SAFEDIR);
	exit(1);
    }

    /* not world writable? */
    if (statbuf.st_mode & 022) {	/* XXX POSIXify this? */
	fprintf(stderr, "%s is potentially writable by non-root users\n",
	    SAFEDIR);
	exit(1);
    }

    /* Starting positions in the argument vectors. */

    new = 0;
    old = 1;

    /* First we set up for the right perl to run. */

    strcpy(realperl, TAINTPERL);
    perlname = strrchr(TAINTPERL, '/');
    if (!perlname++ || *realperl != '/') {
	fprintf(stderr, "Malformed name: %s\n", realperl);
	goto oops;
    }

    newargv[new++] = realperl;

    /* There might be a switch from the #! line */

    while (old < argc && argv[old] && argv[old][0] == '-' && argv[old][1]) {

	if (*validarg) {
	    fprintf(stderr, "Permission denied\n");
	    goto oops;
	}
	else
	    validarg = argv[old];
	if (strchr(argv[old], 'P')) {	/* overkill */
	    fprintf(stderr,"-P not allowed for setuid/setgid script\n");
	    goto oops;
	}

	newargv[new++] = argv[old++];
    }

    /* Now make the new (non-set-id) script. */

    sprintf(newscript, "%s/suid%d", SAFEDIR, getpid());
    oldscript = argv[old++];

    oldfp = fopen(oldscript, "r");
    if (!oldfp) {
	fprintf(stderr, "Can't open %s, errno = %d\n", oldscript, errno);
	goto oops;
    }

    saveumask = umask(0077);
    unlink(newscript);
    newfp = fopen(newscript, "w");
    umask(saveumask);

    if (!newfp) {
	fprintf(stderr, "Can't open %s, errno = %d\n", oldscript, errno);
	goto oops;
    }

    /* Now make sure we clean out the tmp script at some point. */
    /*   XXX Isn't there a better way to do this? */

    for (;;) {
	childpid = fork();
	if (childpid != -1)
	    break;
	if (errno != EAGAIN) {
	    fprintf(stderr, "Can't fork, errno = %d\n", errno);
	    goto oops;
	}
	sleep(10);
    }

    if (!childpid) {
	setpgid(0,0);
	sleep(60);
	if (unlink(newscript) == -1)
	    fprintf(stderr, "Can't unlink %s\n", newscript);
	_exit(0);
    }

    /* Copy over the script, but don't close it yet. */

    while (fgets(buf, sizeof buf, oldfp)) {
	fputs(buf, newfp);
    }
    fseek(oldfp, 0L, 0);

    /* start of code borrowed from suidperl */

    if (fstat(fileno(oldfp),&statbuf) < 0) {	/* normal stat is insecure */
	fprintf(stderr, "Can't stat script \"%s\"",oldscript);
	goto oops;
    }

    if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
	long len;

#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
	/* 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.
	 */
	if (access(oldscript,1)) {	/*double check*/
	    fprintf(stderr,"Permission denied");
	    goto oops;
	}
#else
	/* 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.
	 */
	{
	    struct stat tmpstatbuf;

	    if (
#ifdef HAS_SETREUID
		setreuid(euid,uid) < 0
#else
# if HAS_SETRESUID
		setresuid(euid,uid,(uid_t)-1) < 0
# endif
#endif
		|| getuid() != euid || geteuid() != uid) {
		fprintf(stderr,"Can't swap uid and euid");	/* really paranoid */
		goto oops;
	    }
	    if (stat(oldscript,&tmpstatbuf) < 0) {
		fprintf(stderr,"Permission denied");	/* testing full pathname here */
		goto oops;
	    }
	    if (tmpstatbuf.st_dev != statbuf.st_dev ||
		tmpstatbuf.st_ino != statbuf.st_ino) {
		(void)fclose(oldfp);
		fprintf(stderr,"Permission denied\n");
		goto oops;
	    }
	    if (
#ifdef HAS_SETREUID
              setreuid(uid,euid) < 0
#else
# if defined(HAS_SETRESUID)
              setresuid(uid,euid,(uid_t)-1) < 0
# endif
#endif
              || getuid() != uid || geteuid() != euid) {
		fprintf(stderr,"Can't reswap uid and euid");
		goto oops;
	    }
	    if (!cando(S_IXUSR,0,&statbuf)) {	/* can real uid exec? */
		fprintf(stderr,"Permission denied\n");
		goto oops;
	    }
	}
#endif /* HAS_SETREUID */

	if (!S_ISREG(statbuf.st_mode)) {
	    fprintf(stderr,"Permission denied");
	    goto oops;
	}
	if (statbuf.st_mode & S_IWOTH) {
	    fprintf(stderr,"Setuid/gid script is writable by world");
	    goto oops;
	}
	if (!fgets(buf,sizeof buf, oldfp) ||
	  strncmp(buf,"#!",2) != 0 ) {	/* required even on Sys V */
	    fprintf(stderr,"No #! line");
	    goto oops;
	}
	s = buf+2;
	if (*s == ' ') s++;
	while (!isspace(*s)) s++;
	if (strncmp(s-4,"perl",4) != 0 && strncmp(s-9,"perl",4) != 0) {  /* sanity check */
	    fprintf(stderr,"Not a perl script");
	    goto oops;
	}
	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.
	 */
	len = strlen(validarg);
	if (strncmp(s,validarg,len) != 0 || !isspace(s[len])) {
	    fprintf(stderr,"Args must match #! line");
	    goto oops;
	}

	if (euid) {	/* oops, we're not the setuid root perl */
	    (void)fclose(oldfp);
	    fprintf(stderr,"Can't do setuid\n");
	    goto oops;
	}

	chown(newscript, statbuf.st_uid, statbuf.st_gid);
	chmod(newscript, 0550);

	if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
#ifdef HAS_SETEGID
	    (void)setegid(statbuf.st_gid);
#else
#ifdef HAS_SETREGID
           (void)setregid((gid_t)-1,statbuf.st_gid);
#else
#ifdef HAS_SETRESGID
           (void)setresgid((gid_t)-1,statbuf.st_gid,(gid_t)-1);
#else
	    setgid(statbuf.st_gid);
#endif
#endif
#endif
	    if (getegid() != statbuf.st_gid) {
		fprintf(stderr,"Can't do setegid!\n");
		goto oops;
	    }
	}
	if (statbuf.st_mode & S_ISUID) {
	    if (statbuf.st_uid != euid)
#ifdef HAS_SETEUID
		(void)seteuid(statbuf.st_uid);	/* all that for this */
#else
#ifdef HAS_SETREUID
                (void)setreuid((uid_t)-1,statbuf.st_uid);
#else
#ifdef HAS_SETRESUID
                (void)setresuid((uid_t)-1,statbuf.st_uid,(uid_t)-1);
#else
		setuid(statbuf.st_uid);
#endif
#endif
#endif
	    if (geteuid() != statbuf.st_uid) {
		fprintf(stderr,"Can't do seteuid!\n");
		goto oops;
	    }
	}
	else if (uid) {			/* oops, mustn't run as root */
#ifdef HAS_SETEUID
          (void)seteuid((uid_t)uid);
#else
#ifdef HAS_SETREUID
          (void)setreuid((uid_t)-1,(uid_t)uid);
#else
#ifdef HAS_SETRESUID
          (void)setresuid((uid_t)-1,(uid_t)uid,(uid_t)-1);
#else
          setuid((uid_t)uid);
#endif
#endif
#endif
	    if (geteuid() != uid) {
		fprintf(stderr,"Can't do seteuid!\n");
		goto oops;
	    }
	}

	uid = getuid();
	gid = getgid();
	euid = geteuid();
	egid = getegid();

	if (!cando(S_IXUSR,1,&statbuf)) {
	    fprintf(stderr,"Permission denied\n");	/* they can't do this */
	    goto oops;
	}
    }
    else {
	fprintf(stderr,"Script is not setuid/setgid in suidperl\n");
	goto oops;
    }

    /* end of code borrowed from suidperl */

    fclose(oldfp);
    fclose(newfp);

    /* Now copy the rest of the arguments. */

#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
    /* We've lost ruid and rgid, so force tainting. */
    if (strncmp(perlname, "perl5", 5) == 0) {
	newargv[new++] = "-T";		/* no taintperl in Perl 5 */
    }
#endif

    newargv[new++] = newscript;
    while (old < argc)
	newargv[new++] = argv[old++];
    newargv[new] = 0;

    /* And discard the saved id via exec, finally. */

    execv(newargv[0], newargv);
    fprintf(stderr, "Can't exec %s, errno = %d\n", realperl, errno);

 oops:
    fprintf(stderr,
	"Can't emulate suid--you'll need to run wrapsuid on %s as root\n",
	 oldscript);
    exit(1);
}
/* END OF CODE */