#! /usr/bin/perl -T


# Copyright (C) 2000-2003 Roland Bauerschmidt <rb@debian.org>
#               2004-2025 Marc Haber <mh+debian-packages@zugschlus.de>
#               2005-2009 Joerg Hoh <joerg@joerghoh.de>
#               2006-2011 Stephen Gran <sgran@debian.org>
#               2016 Afif Elghraoui <afif@debian.org>
#               2021-2022 Jason Franklin <jason@oneway.dev>
#               2022 Matt Barry <matt@hazelmollusk.org>
#
# Original adduser:
# Copyright (C) 1997-1999 Guy Maor <maor@debian.org>
#
# Copyright (C) 1995 Ted Hajek <tedhajek@boombox.micro.umn.edu>
#                    Ian A. Murdock <imurdock@gnu.ai.mit.edu>
#
# The general scheme of this program was adapted from the original
# Debian "adduser" program by Ian A. Murdock <imurdock@gnu.ai.mit.edu>.
#
# License: GPL-2+

use 5.36.0;
use utf8;

use Getopt::Long;

use Debian::AdduserCommon 3.139;
use Debian::AdduserLogging 3.139;
use Debian::AdduserRetvalues 3.139;
BEGIN {
    if ( Debian::AdduserCommon->VERSION != version->declare('3.139') ||
         Debian::AdduserLogging->VERSION != version->declare('3.139') ||
         Debian::AdduserRetvalues->VERSION != version->declare('3.139') ) {
           die "wrong module version in adduser, check your packaging or path";
    }
}

my $version = "DVERSION";
my $encode_loaded;
my $codeset;

my $install_more_packages;

BEGIN {
    local $ENV{PERL_DL_NONLAZY}=1;
    eval {
        require File::Find;
    };
    if ($@) {
      $install_more_packages = 1;
    }
    eval {
       require File::Temp;
    };
    if ($@) {
        $install_more_packages = 1;
    };
    eval {
        require Encode;
        Encode->import(qw(encode decode));
    };
    $encode_loaded = 1;
    if ($@) {
        $encode_loaded = 0;
        *encode = sub { return $_[1]; };
        *decode = sub { return $_[1]; };
    }
    $codeset = "US-ASCII";
    eval {
        require I18N::Langinfo;
        I18N::Langinfo->import(qw(langinfo CODESET YESEXPR NOEXPR));
        $codeset = I18N::Langinfo->CODESET;
    };
    if ($@) {
        *langinfo = sub { return shift; };
        *YESEXPR  = sub { "^[yY]" };
        *NOEXPR   = sub { "^[nN]" };
    }
}


BEGIN {
    eval {
        require POSIX;
        POSIX->import(qw(setlocale));
    };
    if ($@) {
        *setlocale = sub { return 1 };
    } else {
        setlocale(&POSIX::LC_MESSAGES, "");
    }
}

my $charset = langinfo($codeset);
if ($encode_loaded) {
    binmode(STDOUT, ":encoding($charset)");
    binmode(STDERR, ":encoding($charset)");
}

our $action;
our $verbose;
our $stdoutmsglevel = "warn";
our $stderrmsglevel = "warn";
our $logmsglevel = "info";
my %pconfig = ();
my %config = ();
my $no_preserve_root;
my ($user,$group);

our @configfiles;
our @defaults = undef;

our @names;

GetOptions (
    'conf|c=s' => \@configfiles,
    'debug' => sub { $verbose = 2; },
    'stdoutmsglevel=s' => \$stdoutmsglevel,
    'stderrmsglevel=s' => \$stderrmsglevel,
    'logmsglevel=s' => \$logmsglevel,
    'help|h' => sub { &usage(); exit 0; },
    'group' => sub { $action = 'delgroup'; },
    '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,
    'quiet|q' => sub { $verbose = 0; },
    'verbose' => sub { $verbose = 1; },
    'version|v' => sub { &version; exit },
) or &usage_error;

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

# make sure that message levels apply for reading configuration
# this will be overridden again after reading configuration
$stdoutmsglevel = sanitize_string($stdoutmsglevel);
$stderrmsglevel = sanitize_string($stderrmsglevel);
$logmsglevel = sanitize_string($logmsglevel);
set_msglevel( $stderrmsglevel, $stdoutmsglevel, $logmsglevel );

##########################################################
# (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);

# 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";
$ENV{"IFS"}=" \t\n";
$ENV{"ENV"}=undef;
$ENV{"BASH_ENV"}=undef;
$ENV{"CDPATH"}=undef;

# everyone can issue "--help" and "--version", but only root can go on
if( $> != 0) {
    log_fatal( mtx("Only root may remove a user or group from the system.") );
    exit( RET_ROOT_NEEDED );
}

# TODO: Handle configuration file input, allow bare input there.
$stdoutmsglevel = sanitize_string($stdoutmsglevel);
$stderrmsglevel = sanitize_string($stderrmsglevel);
$logmsglevel = sanitize_string($logmsglevel);
set_msglevel( $stderrmsglevel, $stdoutmsglevel, $logmsglevel );
if( defined $verbose ) {
    if( $verbose == 0 ) {
        set_msglevel( $stderrmsglevel, "error", $logmsglevel );
    } elsif( $verbose == 1 ) {
        set_msglevel( $stderrmsglevel, "info", $logmsglevel );
    } elsif( $verbose == 2 ) {
        set_msglevel( $stderrmsglevel, "debug", $logmsglevel );
    }
}

# detect the operation mode
$action = $0 =~ /delgroup$/ ? "delgroup" : "deluser";

############################
# checks related to @names #
############################

while (defined(my $arg = shift(@ARGV))) {
    $arg = decode($charset, $arg);
    log_trace("process names %s", $arg);
    if (defined($names[0]) && $arg =~ /^--/) {
        log_fatal( mtx("No options allowed after names.") );
        exit( RET_INVALID_CALL );
    } else {                    # it's a username
        push (@names, sanitize_string($arg, namere) );
    }
}

if ( (! defined $names[0]) || length($names[0]) == 0 || @names > 2) {
    log_fatal( mtx("Only one or two names allowed.") );
    exit( RET_INVALID_CALL );
}


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

log_trace("action $action");

undef(@names);

# TODO: map this to log levels
$ENV{"VERBOSE"} = $verbose;
$ENV{"DEBUG"}   = $verbose;

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

my ($name, $passwd, $pw_uid, $pw_gid, $quota, $comment, $gcos, $pw_homedir, $shell, $expire, $maingroup);

if(defined($user)) {
    ($name, $passwd, $pw_uid, $pw_gid, $quota, $comment, $gcos, $pw_homedir, $shell, $expire) = egetpwnam(encode($charset, $user));
    $pw_homedir = encode($charset, $pw_homedir);

    $maingroup = $pw_gid ? decode($charset, getgrgid($pw_gid)) : "";
}
log_trace("from getpwnam: pw_homedir %s, maingroup %s", $pw_homedir, $maingroup);
if(defined($group)) {
    my ($name, $passwd, $uid, $gr_gid, $quota, $comment, $gcos, $dir, $shell, $expire) = egetgrnam(encode($charset, $group));
}

# 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($name, $passwd, ,$uid, $rest);

    # 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 (($config{remove_home} || $config{remove_all_files} || $config{backup}) && ($install_more_packages)) {
            log_warn( mtx("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.") );
            $config{remove_home}=undef;
            $config{remove_all_files}=undef;
            $config{backup}=undef;
            $config{backup_to}=undef;
        }

        if( ($name, $passwd, $uid, $rest) = egetpwnam(encode($charset, $user)) ) {
            if ( ($uid < $config{"first_system_uid"} ||
                $uid > $config{"last_system_uid" } ) ) {
                log_warn( mtx("The user `%s' is not a system user. Exiting."), $user);
                exit( RET_WRONG_OBJECT_PROPERTIES );
            }
        } else {
            log_info( mtx("The user `%s' does not exist, but --system was given. Exiting."), $user);
            exit( RET_OK );
        }
    } else {
        if (($config{remove_home} || $config{remove_all_files} || $config{backup}) && ($install_more_packages)) {
            log_fatal( mtx("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.") );
            exit( RET_MORE_PACKAGES );
        }
    }

    unless(exist_user($user)) {
        log_fatal( mtx("The user `%s' does not exist."), $user );
        exit( RET_OBJECT_DOES_NOT_EXIST );
    }

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

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

    if($config{"remove_home"} || $config{"remove_all_files"}) {
        log_trace( mtx("remove_home or remove_all_files beginning") );
        log_info( mtx("Looking for files to backup/remove ...") );
        my @mountpoints;
        my $exclude_fstypes = $config{"exclude_fstypes"};
        my $mount;
        if( !open($mount, q{<}, '/proc/mounts') ) {
            log_fatal( mtx("failed to open /proc/mounts: %s") , $! );
            exit( RET_FILE_ERROR );
        }
        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/);
        }
        if( !close($mount) ) {
            log_fatal( mtx("failed to close /proc/mounts: %s"), $!);
            exit( RET_FILE_ERROR );
        }
        my(@files,@dirs);
        if($config{"remove_home"}) {
            # collect all files in user home
            sub home_match {
                my $name = sanitize_string( $File::Find::name, pathre );
                push(@files, $name)
                    if(-f $name || -l $name);
                push(@dirs, $name)
                    if(-d $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
            log_trace("remove_all_files beginning");
            sub find_match {
                my ($dev,$ino,$mode,$nlink,$uid,$gid) = lstat;
                log_trace("find_match %s", $_);
                my $name = sanitize_string( decode($charset, $File::Find::name), pathre );
                log_trace("find_match sanitized %s", $name);
                foreach my $mount (@mountpoints) {
                    if( $name eq $mount ) {
                        log_warn( mtx("Not backing up/removing `%s', it is a mount point."), $name );
                        $File::Find::prune=1;
                        return;
                    }
                }
                foreach my $re ( split ' ', $config{"no_del_paths"} ) {
                    if( $name =~ qr/$re/ ) {
                      log_warn( mtx("Not backing up/removing `%s', it matches %s."), $name, $re);
                      $File::Find::prune=1;
                      return;
                    }
                }
                log_trace("name %s, uid %s, pw_uid %s", $name, $uid, $pw_uid);
                (defined($uid) && ($uid == $pw_uid)) &&
                    (
                        (-f $name && push(@files, $name)) ||
                        (-l $name && push(@files, $name)) ||
                        (-d $name && push(@dirs,  $name)) ||
                        (-S $name && push(@files, $name)) ||
                        (-p $name && push(@files, $name))
                );
                if ( -b $name || -c $name ) {
                    log_warn( mtx("Cannot handle special file %s"), $name );
                }
            } # sub find_match

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

        log_trace("%d files in list to backup/remove", scalar(@files) );
        if($config{"backup"} && (@files)) {
            log_info( mtx("Backing up %d files to be removed to %s ..."), scalar(@files), $config{"backup_to"} );
            my $filesfile = File::Temp->new(TEMPLATE=>"deluser.XXXXX", DIR=>"/tmp");
            my $filesfilename = $filesfile->filename;
            my $backup_name = sanitize_string( $config{"backup_to"} . "/$user.tar", simplepathre );
            log_trace("filesfilename %s, backup_to %s", $filesfilename, $config{"backup_to"});
            my $files = join("\n", map { s/^\///r } @files);
            log_trace( "print to filesfile: %s", $files );
            print $filesfile $files;

            $filesfile->close();
            my $tar = &which('tar');
            &check_backup_suffix();
            $backup_name .= $config{'backup_suffix'};
            $backup_name = sanitize_string( $backup_name, simplepathre );
            log_debug( "backup_name = %s", $backup_name );
            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) {
            log_info( mtx("Removing files ...") );
            unlink(@files) if(@files);
            foreach(reverse(sort(@dirs))) {
                rmdir unless /^$config{dhome}$/ || /^\/$/;
            }
        }
    }

    if (-x '/usr/bin/crontab') {
        log_info( mtx("Removing crontab ...") );

        if (systemcall_silent('/usr/bin/crontab', '-u', $user, '-l') == 0) {
            systemcall_or_warn('/usr/bin/crontab', '-u', $user, '-r');
        }
    } else {
        if ($config{'system'}) {
            log_info( mtx("`%s' not executed. Skipping crontab removal. Package `cron' required."),
            '/usr/bin/crontab' );
        } else {
            log_warn( mtx("`%s' not executed. Skipping crontab removal. Package `cron' required."),
            '/usr/bin/crontab' );
        }
    }

    log_info( mtx("Removing user `%s' ..."), $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");

    exit( RET_OK );
}


if ($action eq 'delgroup') {
    unless (exist_group($group)) {
        if( $config{'system'} ) {
            log_warn( mtx("The group `%s' does not exist."), $group);
            exit( RET_OK );
        } else {
            log_warn( mtx("The group `%s' does not exist."), $group);
            exit( RET_OBJECT_DOES_NOT_EXIST );
        }
    }

    my($dummy,$gid,$members);
    unless( (($dummy, $dummy, $gid, $members ) = egetgrnam($group)) ) {
        log_fatal( mtx("getgrnam `%s' failed: %s. This shouldn't happen."), $group, $! );
        exit( RET_SYSTEM_ERROR );
    }
    if( $config{"system"} &&
        ($gid < $config{"first_system_gid"} ||
         $gid > $config{"last_system_gid" } )) {
        log_fatal( mtx("The group `%s' is not a system group. Exiting."), $group );
        exit( RET_WRONG_OBJECT_PROPERTIES );
    }
    if( $config{"only_if_empty"} && $members ne "") {
        log_fatal( mtx("The group `%s' is not empty!"), $group );
        exit( RET_GROUP_NOT_EMPTY );
    }

    # 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.
    log_info( mtx("Removing group `%s' ..."), $group );
    my $groupdel = &which('groupdel');
    acquire_lock();
    systemcall($groupdel,$group);
    release_lock();
    exit 0;
}


if($action eq 'deluserfromgroup')
{
    unless(exist_user($user)) {
        log_fatal( mtx("The user `%s' does not exist.\n"), $user );
        exit( RET_OBJECT_DOES_NOT_EXIST );
    }
    unless(exist_group($group)) {
        log_fatal( mtx("The group `%s' does not exist.\n"), $group );
        exit( RET_OBJECT_DOES_NOT_EXIST );
    }
    if($maingroup eq $group) {
        log_fatal( mtx("You may not remove the user from their primary group.") );
        exit( RET_NO_PRIMARY_GROUP );
    }

    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) {
        log_fatal( mtx("The user `%s' is not a member of group `%s'."), $user, $group );
        exit( RET_USER_NOT_IN_GROUP );
    }

    log_info( mtx("Removing user `%s' from group `%s' ..."), $user, $group );

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


######

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 regular 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 usage_error {
    &usage;
    exit( RET_INVALID_CALL );
}

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

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

sub check_backup_suffix {
    my $tar = &which('tar');
    my $suffix = "gz";
    if( $config{'backup_suffix'} ) {
        $suffix = sanitize_string($config{'backup_suffix'}, pathre);
    }
    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
        log_warn( mtx("Backup suffix %s unavailable, using gzip."), $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]) {
            log_warn( mtx("Backup suffix %s unavailable, using gzip."), $suffix );
            $suffix = '.gz';
        }
    }
    $config{'backup_suffix'} = $suffix;
}

# Local Variables:
# mode:cperl
# cperl-indent-level:4
# End:

# vim: tabstop=4 shiftwidth=4 expandtab