#! /usr/bin/perl


# Copyright (C) 2000 Roland Bauerschmidt <rb@debian.org>
#
# Based on the Debian "adduser" utility developed by:
#   Guy Maor <maor@debian.org>
#   Ted Hajek <tedhajek@boombox.micro.umn.edu>
#   Ian A. Murdock <imurdock@gnu.ai.mit.edu>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to:
#
#   Free Software Foundation
#   51 Franklin Street, Fifth Floor
#   Boston, MA 02110
#   USA


use strict;
use warnings;

use Getopt::Long;

use Debian::AdduserCommon;

my $version = "3.134";

my $install_more_packages;

BEGIN {
    local $ENV{PERL_DL_NONLAZY}=1;
    eval 'use File::Find';
    if ($@) {
      $install_more_packages = 1;
    }
    #no warnings "File::Find";
    eval 'use File::Temp';
    if ($@) {
      $install_more_packages = 1;
    }
}


BEGIN {
    eval 'use Locale::gettext';
    if ($@) {
        *gettext = sub { shift };
        *textdomain = sub { "" };
        *LC_MESSAGES = sub { 5 };
    }
    eval {
        require POSIX;
        import POSIX qw(setlocale);
    };
    if ($@) {
        *setlocale = sub { return 1 };
    }
}

setlocale(LC_MESSAGES, "");
textdomain("adduser");

my $action = $0 =~ /delgroup$/ ? "delgroup" : "deluser";
our $verbose = 1;
my %pconfig = ();
my %config = ();
my @configfiles;
my @defaults;
my $no_preserve_root;


unless ( 
    GetOptions (
        "quiet|q" => sub {$verbose = 0; },
        "debug" => sub {$verbose = 2; },
        "verbose" => sub {$verbose = 2; },
        "version|v" => sub { &version(); exit 0; },
        "help|h" => sub { &usage(); exit 0;},
        "group" => sub { $action = "delgroup";},
        "conf|c=s" => \@configfiles,
        "system" => \$pconfig{"system"},
        "only-if-empty" => \$pconfig{"only_if_empty"},
        "remove-home" => \$pconfig{"remove_home"},
        "remove-all-files" => \$pconfig{"remove_all_files"},
        "backup" => \$pconfig{"backup"},
        "backup-to=s" => \$pconfig{"backup_to"},
        "backup-suffix=s" => \$pconfig{"backup_suffix"},
        "no-preserve-root" => \$no_preserve_root
    )
) {
    &usage;
    exit 1;
}

# everyone can issue "--help" and "--version", but only root can go on
dief (gtx("Only root may remove a user or group from the system.\n")) if ($> != 0);

if (!@configfiles) {
    @defaults = ("/etc/adduser.conf", "/etc/deluser.conf");
} else {
    @defaults = (@configfiles);
}

# explicitly set PATH, because super (1) cleans up the path and makes deluser unusable;
# this is also a good idea for sudo (which doesn't clean up)
$ENV{"PATH"}="/bin:/usr/bin:/sbin:/usr/sbin";

my @names = ();
my ($user,$group);

######################
# handling of @names #
######################

while (defined(my $arg = shift(@ARGV))) {
  if (defined($names[0]) && $arg =~ /^--/) {
        dief (gtx("No options allowed after names.\n"));
    } else {                    # it's a username
        push (@names, $arg);
    }
}

if(@names == 0) {
    if($action eq "delgroup") {
        print (gtx("Enter a group name to remove: "));
    } else {
        print (gtx("Enter a user name to remove: "));
    }
    chomp(my $answer=<STDIN>);
    push(@names, $answer);
}

if (length($names[0]) == 0 || @names > 2) {
    dief (gtx("Only one or two names allowed.\n"));
}

if(@names == 2) {      # must be deluserfromgroup
    $action = "deluserfromgroup";
    $user = shift(@names);
    $group = shift(@names);
} else {
    if($action eq "delgroup") {
        $group = shift(@names);
    } else {
        $user = shift(@names);
    }
}

undef(@names);

$ENV{"VERBOSE"} = $verbose;
$ENV{"DEBUG"}   = $verbose;

##########################################################
# (1) preseed the config
# (2) read the default /etc/adduser.conf configuration.
# (3) read the default /etc/deluser.conf configuration.
# (4) process commmand line settings
# last match wins
##########################################################

preseed_config (\@defaults,\%config);

foreach(keys(%pconfig)) {
    $config{$_} = $pconfig{$_} if ($pconfig{$_});
}

if (($config{remove_home} || $config{remove_all_files} || $config{backup}) && ($install_more_packages)) {
    fail (8, gtx("In order to use the --remove-home, --remove-all-files, and --backup features,
you need to install the `perl' package. To accomplish that, run
apt-get install perl.\n"));
}


my ($pw_uid, $pw_gid, $pw_homedir, $gr_gid, $maingroup);

if(defined($user)) {
    my @passwd = getpwnam($user);
    $pw_uid = $passwd[2];
    $pw_gid = $passwd[3];
    $pw_homedir = $passwd[7];

    $maingroup = $pw_gid ? getgrgid($pw_gid) : "";
}
if(defined($group)) {
    #($gr_name,$gr_passwd,$gr_gid,$gr_members) = getgrnam($group);
    my @group = getgrnam($group);
    $gr_gid = $group[2];
}

# arguments are processed:
#
#  $action = "deluser"
#     $user          name of the user to remove
#
#  $action = "delgroup"
#     $group         name of the group to remove
#
#  $action = "deluserfromgroup"
#     $user          the user to be remove
#     $group         the group to remove him/her from


if($action eq "deluser") {
    my($dummy1,$dummy2,$uid);

    # Don't allow a non-system user to be deleted when --system is given
    # Also, "user does not exist" is only a warning with --system, but an
    # error without --system.
    if( $config{"system"} ) {
        if( ($dummy1,$dummy2,$uid) = getpwnam($user) ) {
            if ( ($uid < $config{"first_system_uid"} ||
                $uid > $config{"last_system_uid" } ) ) {
                warnf (gtx("The user `%s' is not a system user. Exiting.\n"), $user) if $verbose;
                 exit 1;
            }
        } else {
            warnf (gtx("The user `%s' does not exist, but --system was given. Exiting.\n"), $user) if $verbose;
            exit 0;
        }
    }

    unless(exist_user($user)) {
        fail (2,gtx("The user `%s' does not exist.\n"),$user);
    }

    # Warn in any case if you want to remove the root account
    if ((defined($pw_uid)) && ($pw_uid == 0) && (!defined($no_preserve_root)))  {
        printf (gtx("WARNING: You are just about to delete the root account (uid 0)\n"));
        printf (gtx("Usually this is never required as it may render the whole system unusable\n"));
        printf (gtx("If you really want this, call deluser with parameter --no-preserve-root\n"));
        printf (gtx("Stopping now without having performed any action\n"));
        exit 9;
    }

    # consistency check
    # if --backup-to is specified, --backup should be set too
    if ($pconfig{"backup_to"}) {
        $config{"backup"} = 1;
    }

    if($config{"remove_home"} || $config{"remove_all_files"}) {
        s_print (gtx("Looking for files to backup/remove ...\n"));
        my @mountpoints;
        my $exclude_fstypes = $config{"exclude_fstypes"};
        open(MOUNT, '/proc/mounts')
            || fail (4 ,gtx("failed to open /proc/mounts: %s\n", $!));
        while (<MOUNT>) {
          my @temparray = split;
          my ($fstype, $fname) = ($temparray[2], $temparray[1]);

          next if $fname eq '/';
          next if $fname eq '/home';

          push @mountpoints,$fname if ($fstype =~ /$exclude_fstypes/);
        }
        close(MOUNT) or dief (gtx("failed to close /proc/mounts: %s\n",$!));
        my(@files,@dirs);
        if($config{"remove_home"}) {
            # collect all files in user home
            sub home_match {
                push(@files, $File::Find::name)
                    if(-f $File::Find::name || -l $File::Find::name);
                push(@dirs, $File::Find::name)
                    if(-d $File::Find::name);
            } # sub home_match

            File::Find::find({wanted => \&home_match, untaint => 1, no_chdir => 1}, $pw_homedir)
                if(-d "$pw_homedir");
            push(@files, "/var/mail/$user")
                if(-e "/var/mail/$user");
        }

        if ($config{"remove_all_files"}) {
            # collect all files on system belonging to that user
            sub find_match {
                my ($dev,$ino,$mode,$nlink,$uid,$gid) = lstat;
                foreach my $mount (@mountpoints) {
                    if( $File::Find::name eq $mount ) {
                        s_printf (gtx("Not backing up/removing `%s', it is a mount point.\n"),$File::Find::name) if ($verbose > 1);
                        $File::Find::prune=1;
                        return;
                    }
                }
                foreach my $re ( split ' ', $config{"no_del_paths"} ) {
                    if( $File::Find::name =~ qr/$re/ ) {
                      s_printf (gtx("Not backing up/removing `%s', it matches %s.\n"),$File::Find::name,$re) if ($verbose > 1);
                      $File::Find::prune=1;
                      return;
                    }
                }
                (defined($uid) && ($uid == $pw_uid)) &&
                    (
                        (-f $File::Find::name && push(@files, $File::Find::name)) ||
                        (-l $File::Find::name && push(@files, $File::Find::name)) ||
                        (-d $File::Find::name && push(@dirs, $File::Find::name)) ||
                        (-S $File::Find::name && push(@files, $File::Find::name)) ||
                        (-p $File::Find::name && push(@files, $File::Find::name))
                    );
                if ( -b $File::Find::name || -c $File::Find::name ) {
                    warnf (gtx("Cannot handle special file %s\n"),$File::Find::name);
                }
            } # sub find_match

            File::Find::find({wanted => \&find_match, untaint => 1, no_chdir => 1}, '/');
        }

        if($config{"backup"}) {
            s_printf (gtx("Backing up files to be removed to %s ...\n"),$config{"backup_to"});
            my $filesfile = new File::Temp(TEMPLATE=>"deluser.XXXXX", DIR=>"/tmp");
            my $filesfilename = $filesfile->filename;
            my $backup_name = $config{"backup_to"} . "/$user.tar";
            print $filesfile join("\n", map { s/^\///r } @files);
    
            $filesfile->close();
            my $tar = &which('tar');
            &check_backup_suffix();
            $backup_name .= $config{'backup_suffix'};
            print "backup_name = $backup_name\n";
            &systemcall($tar, "--directory", "/", "--auto-compress", "-cf", $backup_name, "--files-from", $filesfilename);
            chmod 0600, $backup_name;
            my $rootid = 0;
            chown $rootid, $rootid, $backup_name;
            unlink($filesfilename);
        }

        if(@files || @dirs) {
            s_print (gtx("Removing files ...\n"));
            unlink(@files) if(@files);
            foreach(reverse(sort(@dirs))) {
                rmdir unless /^$config{dhome}$/ || /^\/$/;
            }
        }
    }

    if (-x '/usr/bin/crontab') {
        s_print(gtx("Removing crontab ...\n"));

        if (&systemcall_silent('/usr/bin/crontab', '-u', $user, '-l') == 0) {
            &systemcall_or_warn('/usr/bin/crontab', '-u', $user, '-r');
        }
    } else {
        warnf(gtx("`%s' not executed. Skipping crontab removal. Package `cron' required.\n"),
            '/usr/bin/crontab');
    }

    s_printf(gtx("Removing user `%s' ...\n"), $user);
    acquire_lock();
    &systemcall('/usr/sbin/userdel', $user);
    release_lock();

    &systemcall('/usr/local/sbin/deluser.local', $user, $pw_uid,
        $pw_gid, $pw_homedir) if (-x "/usr/local/sbin/deluser.local");

    s_print(gtx("Done.\n"));
    exit 0;
}


if ($action eq 'delgroup') {
    unless (exist_group($group)) {
        warnf (gtx("The group `%s' does not exist.\n"), $group) if $verbose;
        exit(0) if $config{'system'};
        exit(3);
    }

    my($dummy,$gid,$members);
    if( !(($dummy, $dummy, $gid, $members ) = getgrnam($group)) ) {
        fail (4 ,gtx("getgrnam `%s' failed. This shouldn't happen.\n"), $group);
    }
    if( $config{"system"} &&
        ($gid < $config{"first_system_gid"} ||
         $gid > $config{"last_system_gid" } )) {
        warnf (gtx("The group `%s' is not a system group. Exiting.\n"), $group) if $verbose;
        exit 3;
    }
    if( $config{"only_if_empty"} && $members ne "") {
        fail (5, gtx("The group `%s' is not empty!\n"),$group);
    }

    # groupdel will error out if there are users left that
    # have $group as primary group. We are not checking this
    # ourself since this would mean enumerating all users.
    s_printf (gtx("Removing group `%s' ...\n"),$group);
    my $groupdel = &which('groupdel');
    acquire_lock();
    &systemcall($groupdel,$group);
    release_lock();
    s_print (gtx("Done.\n"));
    exit 0;
}


if($action eq 'deluserfromgroup')
{
    unless(exist_user($user)) {
        fail (2, gtx("The user `%s' does not exist.\n"),$user);
    }
    unless(exist_group($group)) {
        fail (3, gtx("The group `%s' does not exist.\n"),$group);
    }
    if($maingroup eq $group) {
        fail (7, gtx("You may not remove the user from their primary group.\n"));
    }

    my $is_member;
    my @members;

    foreach my $member (get_group_members($group)) {

        if ($member eq $user) {
            $is_member = 1;
            next;
        }

        push @members, $member;
    }

    unless($is_member) {
        fail (6, gtx("The user `%s' is not a member of group `%s'.\n"),$user,$group);
    }

    s_printf (gtx("Removing user `%s' from group `%s' ...\n"),$user,$group);

    acquire_lock();
    &systemcall('/usr/bin/gpasswd', '-M', join(',', @members), $group);
    release_lock();

    s_print (gtx("Done.\n"));
}


######

sub fail {
  my ($errorcode, $format, @args) = @_;
  warnf "$format",@args;
  exit $errorcode;
}

sub version {
    printf (gtx("deluser version %s\n\n"), $version);
    print gtx("Removes users and groups from the system.

For detailed copyright information, please refer to
/usr/share/doc/adduser/copyright.
\n");

    print gtx("This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License, /usr/share/common-licenses/GPL, for more details.
");
}

sub usage {
    printf gtx(
"deluser [--system] [--remove-home] [--remove-all-files] [--backup]
        [--backup-to dir] [--backup-suffix str] [--conf file]
        [--quiet] [--verbose] [--debug] user

  remove a normal user from the system

deluser --group [--system] [--only-if-empty] [--conf file] [--quiet]
        [--verbose] [--debug] group
delgroup [--system] [--only-if-empty] [--conf file] [--quiet]
         [--verbose] [--debug] group
  remove a group from the system

deluser [--conf file] [--quiet] [--verbose] [--debug] user group
  remove the user from a group\n");
}

sub exist_user {
    my $exist_user = shift;
    return(defined getpwnam($exist_user));
}

sub exist_group {
    my $exist_group = shift;
    return(defined getgrnam($exist_group));
}

sub check_backup_suffix {
    my $tar = &which('tar');
    my $suffix = $config{'backup_suffix'} || 'gz';
    if ($suffix !~ /^\./) {
        $suffix = ".$suffix";
    }
    my $filename = '/tmp/deluser-check.tar';
    my $testfile = 'usr/sbin/deluser';
    &systemcall_silent_error($tar, '--auto-compress', '--directory', '/', '-cf', $filename.$suffix, $testfile);

    if ($?) {
        # compressor recognized, not available
        warnf gtx("Backup suffix %s unavailable, using gzip.\n"), $suffix;
        $suffix = '.gz';
    } else {
        # no error, check if compressed
        &systemcall_silent($tar, '--directory', '/', '-cf', $filename, $testfile);

        my @zstat = stat($filename.$suffix);
        my @ustat = stat($filename);
        unlink($filename, $filename.$suffix);
        if ($zstat[7] == $ustat[7]) {
            warnf gtx("Backup suffix %s unavailable, using gzip.\n"), $suffix;
            $suffix = '.gz';
        }
    }
    $config{'backup_suffix'} = $suffix;
}

# vim: tabstop=4 shiftwidth=4 expandtab