runuser(1) clone to emulate Red Hat Linux

runuser.pl

#!/usr/bin/perl
##
## runuser(1) clone to emulate Red Hat Linux
## Copyright (c) 2008-2009 SATOH Fumiyasu @ OSS Technology Corp.
##               <http://www.osstech.co.jp>
##
## License: GNU General Public License version 2 or later
## Date: 2009-03-12, since 2008-06-13
##

use strict;
use warnings;
use English qw(-no_match_vars);
use Getopt::Long;

use constant true => 1;
use constant false => undef;

sub pinfo {
  chomp(my $m = join('', @_));
  print STDERR "$0: INFO: $m\n";
}

sub pwarn {
  chomp(my $m = join('', @_));
  print STDERR "$0: WARNING: $m\n";
}

sub perr {
  chomp(my $m = join('', @_));
  print STDERR "$0: ERROR: $m\n";
}

sub pdie {
  perr(@_);
  exit(1);
}

my $group = undef;
my $shell = undef;
my $login_shell_f = false;
my $preserve_env_f = false;
my $not_implemented = sub { pdie "$_[0] option not implemented"; };

my $cmd_usage = "Usage: $0 [OPTIONS] [-] [USER [ARG] ...]";

{
  ## Trap warning messages from Getopt::Long
  local($SIG{'__WARN__'}) = sub {
    my ($msg) = shift(@_);
    pwarn $msg;
  };
  ## I don't like default behavior.
  Getopt::Long::Configure('bundling');
  Getopt::Long::Configure('no_ignore_case');
  Getopt::Long::Configure('no_auto_abbrev');
  GetOptions(
    'l|login' =>		\$login_shell_f,
    'g|group=s' =>		\$group,
    'G|groups=s' =>		$not_implemented,
    'c|command=s' =>		$not_implemented,
    'f|fast' =>			$not_implemented,
    'm|p|preserve-environment' =>\$preserve_env_f,
    's|shell=s' =>		\$shell,
  ) || exit(1);
}

my $login = @ARGV ? shift(@ARGV) : 'root';
my @argv = @ARGV;

my @pwent = getpwnam($login);
@pwent || pdie "User does not exist: $login";

my $uid = $pwent[2];
my $gid = defined($group) ? getgrnam($group) : $pwent[3];
defined($gid) || pdie "Group does not exist: $group";

defined($shell) || ($shell = $pwent[8] || '/bin/sh');
my $argv0 = $shell;
$argv0 =~ s#.*/#-# if ($login_shell_f);

unless ($preserve_env_f) {
  for my $env_name (keys %ENV) {
    next if ($env_name =~ /^(LANG|LC_\w+|PATH)$/);
    delete($ENV{$env_name});
  }
  $ENV{'LOGNAME'} = $ENV{'USER'} = $login;
  $ENV{'HOME'} = $pwent[7];
  $ENV{'SHELL'} = $shell;
}

$EGID = "$gid $gid";
$ERRNO && pdie "Cannot change effective GID: $gid: $!";
$GID = $gid;
$ERRNO && pdie "Cannot change real GID: $gid: $!";
$EUID = $uid;
$ERRNO && pdie "Cannot change effective UID: $uid: $!";
$UID = $uid;
$ERRNO && pdie "Cannot change real UID: $uid: $!";

unless (exec {$shell} $argv0, @argv) {
  pdie "Cannot execute command: $shell: $!";
}