#!/usr/bin/env perl
# with --- run program with special properties
# Author: Noah Friedman <friedman@splode.com>
# Created: 1995-08-14
# Public domain

# $Id: with,v 1.13 2011/05/06 19:23:03 friedman Exp $

# Commentary:

# TODO: create optional socket streams for stdin or stdout before invoking
# subprocess.

# Code:

$^W = 1; # enable warnings

use strict;
use Symbol;
use POSIX qw(setsid);
use Getopt::Long;
use Pod::Usage;

(my $progname = $0) =~ s|.*/||;
my $bgfn;
my $bgopt = 0;

my %opt = ( foreground => 0,
            include    => [],
          );

sub err
{
  my $fh = (ref ($_[0]) ? shift : *STDERR{IO});
  print $fh join (": ", $progname, @_), "\n";
  exit (1);
}

sub get_includes
{
  unshift @INC, @_;
  push (@INC,
        "$ENV{HOME}/lib/perl",
        "$ENV{HOME}/lib/perl/include");

  eval { require "syscall.ph" } if defined $opt{groups};
}

sub numberp
{
  defined $_[0] && $_[0] =~ m/^-?\d+$/o;
}

sub group2gid
{
  my $g = shift;
  return $g if numberp ($g);
  my $gid = getgrnam ($g);
  return $gid if defined $gid && numberp ($gid);
  err ($g, "no such group");
}

sub user2uid
{
  my $u = shift;
  return $u if numberp ($u);
  my $uid = getpwnam ($u);
  return $uid if defined $uid && numberp ($uid);
  err ($u, "no such user");
}

sub set_cwd
{
  my $d = shift;
  chdir ($d) || err ("chdir", $d, $!);
}

sub set_egid
{
  my $sgid = group2gid (shift);
  my $egid = $) + 0;

  $) = $sgid;
  err ($sgid, "cannot set egid", $!) if ($) == $egid && $egid != $sgid);
}

sub set_gid
{
  my $sgid = group2gid (shift);
  my $rgid = $( + 0;
  my $egid = $) + 0;

  $( = $sgid;
  $) = $sgid;
  err ($sgid, "cannot set rgid", $!) if ($( == $rgid && $rgid != $sgid);
  err ($sgid, "cannot set egid", $!) if ($) == $egid && $egid != $sgid);
}

sub big_endian_p
{
  my $x = 1;
  my @y = unpack ("c2", pack ("i", $x));
  return ($y[0] == 1) ? 0 : 1;
}

# This function is more complex than it ought to be because perl does not
# export the setgroups function.  It exports the getgroups function by
# making $( and $) return multiple values in the form of a space-separated
# string, but you cannot *set* the group list by assigning those variables.
# There is no portable way to determine what size gid_t is, so we must guess.
sub set_groups
{
  my @glist = sort { $a <=> $b } map { group2gid ($_) } split (/[ ,]/, shift);

  my $expected = join (" ", $(+0, reverse @glist);
  my @p = (big_endian_p() ? ("n", "N", "i") : ("v", "V", "i"));

  for my $c (@p)
    {
      err ("setgroups", $!)
        if (syscall (&SYS_setgroups, @glist+0, pack ("$c*", @glist)) == -1);
      return if ("$(" eq $expected);
    }
  err ("setgroups", "Could not determine gid_t");
}

sub set_pgrp
{
  setpgrp ($$, shift) || err ("setpgrp", $!);
}

sub set_priority
{
  my $prio = shift () + 0;
  setpriority (0, 0, $prio) || err ("setpriority", $prio, $!);
}

sub set_proxy
{
  my $proxy = shift;

  # Some programs use case-sensitive variable names; some don't.
  map { $ENV{$_} = $ENV{uc $_} = $proxy;
      } (qw(http_proxy https_proxy ftp_proxy));
}

sub set_root
{
  my $d = shift;
  chroot ($d) || err ("chroot", $d, $!);
  chdir ("/");
}

sub set_euid
{
  my $suid = user2uid (shift);
  my $euid = $>;

  $> = $suid;
  err ($suid, "cannot set euid", $!) if ($> == $euid && $euid != $suid);
}

sub set_uid
{
  my $suid = user2uid (shift);
  my $ruid = $<;
  my $euid = $>;

  $< = $suid;
  $> = $suid;
  err ($suid, "cannot set ruid", $!) if ($< == $ruid && $ruid != $suid);
  err ($suid, "cannot set euid", $!) if ($> == $euid && $euid != $suid);
}


sub background
{
  my $pid = fork;
  die "$@" if $pid < 0;
  if ($pid == 0)
    {
      # Backgrounded programs may expect to be able to read input from the
      # user if stdin is a tty, but we will no longer have any job control
      # management because of the double fork and exit.  This can result in
      # a program either blocking on input (if still associated with a
      # controlling terminal) and stopping, or stealing input from a
      # foreground process (e.g. a shell).  So redirect stdin to /dev/null.
      open (STDIN, "< /dev/null") if (-t STDIN);
      return *STDERR{IO};
    }

  exit (0) unless $opt{foreground};
  wait;
  exit ($?);
}

sub dosetsid
{
  background ();
  setsid (); # dissociate from controlling terminal
  return *STDERR{IO};
}

sub daemon
{
  # Don't allow any file descriptors, including stdin, stdout, or
  # stderr to be propagated to children.
  $^F = -1;
  dosetsid ();
  # Duped in case we've closed stderr but can't exec anything.
  my $saved_stderr = gensym;
  open ($saved_stderr, ">&STDERR");
  close (STDERR);
  close (STDOUT);
  close (STDIN);
  return $saved_stderr;
}

sub notty
{
  # Don't allow any file descriptors other than stdin, stdout, or stderr to
  # be propagated to children.
  $^F = 2;
  dosetsid ();
  # Duped in case we've closed stderr but can't exec anything.
  my $saved_stderr = gensym;
  open ($saved_stderr, ">&STDERR");
  open (STDIN,  "+</dev/null");
  open (STDERR, "+<&STDIN");
  open (STDOUT, "+<&STDIN");
  return $saved_stderr;
}


sub set_bg_option
{
  my %bgfntbl =
    ( 1 => \&background,
      2 => \&daemon,
      4 => \&notty,
      8 => \&dosetsid,
    );

  $bgopt |= $_[0];
  $bgfn   = $bgfntbl{$bgopt};
}

sub parse_options
{
  my $help = -1;

  local *ARGV = \@{$_[0]}; # modify our local arglist, not real ARGV.
  Getopt::Long::config (qw(bundling auto_abbrev require_order));
  my $succ = GetOptions
    ("h|help|usage+"    => \$help,
     "c|cwd=s"          => \$opt{cwd},
     "d|display=s"      => \$ENV{DISPLAY},
     "H|home=s"         => \$ENV{HOME},
     "G|egid=s"         => \$opt{egid},
     "g|gid=s"          => \$opt{gid},
     "I|include=s@"     => \@{$opt{include}},
     "l|groups=s"       => \$opt{groups},
     "m|umask=s"        => \$opt{umask},
     "n|name=s"         => \$opt{name},
     "P|priority=i"     => \$opt{priority},
     "proxy=s"          => \$opt{proxy},
     "p|pgrp=i"         => \$opt{pgrp},
     "r|root=s"         => \$opt{root},
     "U|euid=s"         => \$opt{euid},
     "u|uid=s"          => \$opt{uid},

     "f|fg|foreground"  => \$opt{foreground},
     "b|bg|background"  => sub { set_bg_option (1); $opt{foreground} = 0 },
     "a|daemon|demon"   => sub { set_bg_option (2) },
     "N|no-tty|notty"   => sub { set_bg_option (4) },
     "s|setsid"         => sub { set_bg_option (8) },
    );

  pod2usage (-exitstatus => 1, -verbose => 0) unless $succ;
  pod2usage (-exitstatus => 0, -verbose => $help) if $help >= 0;
  pod2usage (-exitstatus => 1, -verbose => 0,
             -message => "$progname: need to specify command to run.\n")
    unless @ARGV;

  my $n = 0;
  do { $n++ if $bgopt & 1 } while ($bgopt >>= 1);
  err ("Can only specify one of --background, --daemon, --notty, or --setsid")
    if ($n > 1);
}

sub main
{
  parse_options (\@_);
  get_includes (@{$opt{include}});

  umask        (oct ($opt{umask})) if defined $opt{umask};
  set_gid      ($opt{gid})         if defined $opt{gid};
  set_egid     ($opt{egid})        if defined $opt{egid};
  set_groups   ($opt{groups})      if defined $opt{groups};
  set_root     ($opt{root})        if defined $opt{root};
  set_cwd      ($opt{cwd})         if defined $opt{cwd};
  set_priority ($opt{priority})    if defined $opt{priority};
  set_uid      ($opt{uid})         if defined $opt{uid};
  set_euid     ($opt{euid})        if defined $opt{euid};
  set_proxy    ($opt{proxy})       if defined $opt{proxy};

  my $stderr = $bgfn ? &$bgfn () : *STDERR{IO};

  my $runprog = $_[0];
  if ($opt{name})
    {
      shift   @_;
      unshift @_, $opt{name};
    }
  local $^W = 0; # avoid implicit warnings from exec
  exec ($runprog @_) || err ($stderr, "exec", $runprog, $!);
}

main (@ARGV);

__END__

=head1 NAME

with - run program with special properties

=head1 SYNOPSIS

 with {-h|--help}            {-d|--display DISP}   {-c|--cwd DIR}
      {-D|--debug}           {-H|--home HOME}      {-r|--root ROOT}
      {-I|--include DIR}     {-n|--name ARGV0}

      {-m|--umask UMASK}     {-G|--egid EGID}      {-b|--background}
      {-P|--priority NICE}   {-g|--gid GID}        {-f|--foreground}
      {-p|--pgrp PGRP}       {-l|--groups GLIST}   {-a|--daemon}
                             {-U|--euid EUID}      {-N|--no-tty}
                             {-u|--uid UID}        {-s|--setsid}

      [command {args...}]

 The -h option may be repeated up to 3 times for increased verbosity.

=head1 OPTIONS

=over 8

=item B<-h>, B<--help>

Usage information.
May be repeated 1-3 times for more verbosity.

=item B<-D>, B<--debug>

Turn on interactive debugging in perl.

=item B<-I>, B<--include=>I<DIR>

Include DIR in @INC path for perl.
This option may be specified multiple times to append search paths to perl.

=item B<-d>, B<--display=>I<DISP>

Run with DISP as the X server display.

=item B<-H>, B<--home=>I<HOME>

Set $HOME.

=item B<-n>, B<--name=>I<ARGV0>

Set name of running program (argv[0]).

=item B<-c>, B<--cwd=>I<DIR>

Run with DIR as the current working directory.  This directory is relative
to the root directory as specified by B<--root>, or C</>.

=item B<-r>, B<--root=>I<ROOT>

Set root directory (via `chroot' syscall) to ROOT.

=item B<-G>, B<--egid=>I<EGID>

Set `effective' group ID.

=item B<-g>, B<--gid=>I<GID>

Set both `real' and `effective' group ID.

=item B<-l>, B<--groups=>I<GLIST>

Set group list to comma-separated GLIST.

=item B<-U>, B<--euid=>I<EUID>

Set `effective' user ID.

=item B<-u>, B<--uid=>I<UID>

Set both `real' and `effective' user ID.

=item B<-m>, B<--umask=>I<UMASK>

Set umask.

=item B<-P>, B<--priority=>I<NICE>

Set scheduling priority to NICE (-20 to 20).

=item B<-p>, B<--pgrp=>I<PGRP>

Set process group.

=back

The following options cause the resulting process to be backgrounded
automatically but differ in various ways:

=over 8

=item B<-b>, B<--background>

Run process in background.
This is the default with the B<--daemon>, B<--no-tty>,
and B<--setsid> options.

=item B<-f>, B<--foreground>

Do not put process into the background when using the B<--daemon>,
B<--no-tty>, and B<--setsid> options.
In all other cases the default is to remain in the foreground.

=item B<-a>, B<--daemon>

Run process in "daemon" mode.  This closes stdin, stdout, and stderr,
dissociates the process from any controlling terminal, and backgrounds the
process.

=item B<-N>, B<--no-tty>

Run process in background with no controlling terminal and with stdin,
stdout, and stderr redirected to /dev/null.

=item B<-s>, B<--setsid>

Dissociate from controlling terminal.  This automatically backgrounds the
process but does not redirect any file descriptors.

=back

=head1 DESCRIPTION

This program tweaks the environment of the process to be invoked.
It should be relatively self-explanatory.

=cut