#!/usr/bin/env perl
# $Id: sheval.pl,v 1.4 2012/10/19 19:58:21 ksb Exp $
# $Source: /usr/msrc/usr/local/libexec/jacket/RCS/sheval.pl,v $
#
# The dynamic evaluation and environment helmet/jacket.  We allow
# the specification of a SHEVAL_SET_variable=shell-command  which renders
#	variable=`shell-command`
# into the escalated environment, and removes the source specification
# from the environment.  If that variable begins with SHEVAL_SET_ it is
# processed _after_ all the pending variables.  This allows you to
# order some evaluations at the end.
#
# Any non-zero exit code from a shell-command fails the escalation (with
# that same exit code).

use strict;
use Getopt::Std;
# Auto-flush standard out, we need the child to see it ASAP
select STDERR; $| = 1;
select STDOUT; $| = 1;

my($progname, $usage, %opts);
($progname = $0) =~ s,.*/,,;

# tainted fixes from perlsec
my($mypath) = "/bin:/usr/bin:/usr/local/bin:/usr/openwin/bin:/usr/X11/bin:/usr/X11R6/bin:/usr/local/sbin";
my($herpath) = $ENV{'PATH'} =~ m/^(.*)/o;
if (defined($herpath)) {
	if ($herpath =~ m/[']/o) {
		$herpath =~ s/[']/'\\''/g;
	}
	$herpath = "export PATH='$herpath';";
} else {
	$herpath = '';
}

$ENV{PATH} = $mypath;
$ENV{SHELL} = '/bin/sh' if exists $ENV{SHELL};
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};

my($Reveal) = 'SHEVAL_REVEAL';
my($WarnEnv) ='SHEVAL_WARN';
my($Set) = 'SHEVAL_SET_';
my($Remove) = 'SHEVAL_UNSET';
my($warn) = 'Sorry';

$usage = "$progname: usage -P pid [helmet-opts] -- mnemonic program euid:egid cred_type:cred";
getopts("VhHP:u:g:f:j:m:R:C:", \%opts);

if ($opts{'V'}) {
	print "$progname: ", '$Id: sheval.pl,v 1.4 2012/10/19 19:58:21 ksb Exp $', "\n";
	exit 0;
}

if ($opts{'h'}) {
        print   "$usage\n",
                "$progname: usage -h\n",
                "$progname: usage -V\n",
		"P pid       process that we jacket\n",
                "h           print only this help message\n",
                "V           show only version info\n",
                "helmet-opts arguments to any op helmet program\n",
		"mnemonic    the requested op mnemonic\n",
		"program     client application\n",
		"euid:egid   target login and group uids\n",
		"cred_type   the credential type that granted access (groups, users, or netgroups)\n",
		"cred        the matching group, login, or netgroup\n";
	exit 0;
}
if ($opts{'H'}) {
	print	"$progname: assign dynamic values in an escalated environment\n",
		"${Set}var=cmd\texport var=\`cmd\`\n",
		"$WarnEnv\t\tSpecific failure message\n",
		"$Reveal\t\tstandard reveal logic\n",
		"$Remove=list\tcomma separated list of variables to delete\n";
	exit 0;
}

# Untaint our params, common code to most jackets. --ksb
shift @ARGV if (scalar(@ARGV) && $ARGV[0] =~ m/^--$/o);
if (scalar(@ARGV) != 4) {
	print STDERR "$progname: exactly 4 positional parameters required\n";
	print "64\n" if $opts{'P'};
	exit 64;
}
if ($ARGV[0] !~ m|^([-/\@\w.]+)$|o) {
	print STDERR "$progname: mnemonic is zero width, or spelled badly\n";
	print "64\n";
	exit 64;
}
my($MNEMONIC) = $1;
if ($ARGV[1] !~ m|^([-/\@\w.]+)$|o) {
	print STDERR "$progname: program specification looks bogus\n";
	print "64\n";
	exit 64;
}
my($PROGRAM) = $1;
if ($ARGV[2] !~ m/^(\d+):(\d+)$/o) {
	print STDERR "$progname: euid:egid format error (wants digits:digits)\n";
	print "65\n";
	exit 65;
}
my($EUID, $EGID) = ($1, $2);
if ($ARGV[3] !~ m/^([^:]*):([^:]*)$/o) {
	print STDERR "$progname: cred_type:cred $ARGV[3] missing colon\n";
	print "76\n";
	exit 76;
}

my($our_name, $our_uid, $our_gid, $our_home);
($our_name, undef, $our_uid, $our_gid, undef, undef, undef, $our_home) = getpwuid($<);
if (!$our_home) {
	print STDERR "$progname: getpwuid: $<: $!\n";
	print "67\n";
	exit 67;
}

# We could pass $LOGNAME in the env from op to get the right name in
# the case where more than 1 login has the same uid.  But you are in
# trouble if you do that anyway, so I'm not going to help you.  --ksb
my($her_uid, $her_gid, $her_name, $her_home);
($her_name, undef, $her_uid, $her_gid, undef, undef, undef, $her_home) = getpwuid($EUID);
defined $her_home or do {
	print STDERR "$progname: getpwuid: $EUID: $!\n";
	print "67\n";
	exit 67;
};


# Common reveal logic.
if (exists $ENV{$Reveal} and $ENV{$Reveal} =~ m/(.*)/o) {
	print "-$Reveal\n~$1\n";
}

my(@todo) = ();
my($done) = 0;
my($env, $exset, $inset, $from, $line);
my($value, $encoding, $sep);
@todo = grep(m/^SHEVAL_SET_/o, keys(%ENV));
while ($env = shift(@todo)) {
	# If this is a multiple eval, push it, but don't tell op yet,
	# take the name or take $_ if name is empty
	if ($env =~ m/^SHEVAL_SET_(SHEVAL_SET_.*)$/o) {
		$inset = $1;
		$exset = undef;
		push(@todo, "$1");
	} elsif ($env =~ m/^SHEVAL_SET_(.+)$/o or '_' =~ m/(.)/o) {
		$inset = $1;
		$exset = $1;
	}
	print "-$env\n";
	if ($ENV{$env} =~ m/^$/o) {
		$ENV{$env} = 'hostname';
	}
	$ENV{$env} =~ m/(.*)/o;
	delete $ENV{$env};
	if (!open($from, '-|', "$herpath$1")) {
		print STDERR "$progname: $inset: command failed to launch\n";
		print "65\n";
		exit 65;
	}

	# We must 1-behind the newlines like sh command quotes do.
	$sep = $encoding = $value = '';
	while ($line = <$from>) {
		$value .= $line;
		chomp $line;
		$line =~ s/"/\\d/g;
		$line =~ s/`/\\o/g;
		$line =~ s/'/\\q/g;
		$line =~ s/\\/\\\\/g;
		$line =~ s/\t/\\t/g;
		$encoding .= $sep.$line;
		$sep = '\\n';
	}
	close($from);
	if (0 != $?) {
		my($status) = $?;
		print STDERR "$progname: $warn\n";
		$status /= 256 if ($status > 255);
		exit $status;
	}
	if (defined($exset)) {
		if ($value =~ m/["\n\\]/o) {
			print "\"\$$exset=$encoding\"\n";
		} else {
			print "$exset=$value";
		}
		++$done;
	}
	$ENV{$inset} = $value;
}

my($del) = 0;
if (exists $ENV{$Remove} and $ENV{$Remove} =~ m/^([^="]*)$/o) {
	print "-$Remove\n";
	@todo = split(m/[,\n]+/o, $1);
	while ($env = shift(@todo)) {
		++$del if exists $ENV{$env};
		print "-$env\n";
	}
}

print "# $progname: added $done and deleted $del environment entries\n";
my($kid, $status);
$status = 0;
if ($opts{'P'}) {
	open STDOUT, ">/dev/null";
	$kid = waitpid $opts{'P'}, 0;
	$status = $? < 256 ? $? : ($? >> 8);
}

# Exit with (a function of) her exit code
exit $status;