mmdebstrap/mmdebstrap

#!/usr/bin/perl
#
# © 2018 - 2021 Johannes Schauer Marin Rodrigues <josch@mister-muffin.de>
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# The software is provided "as is", without warranty of any kind, express or
# implied, including but not limited to the warranties of merchantability,
# fitness for a particular purpose and noninfringement. In no event shall the
# authors or copyright holders be liable for any claim, damages or other
# liability, whether in an action of contract, tort or otherwise, arising
# from, out of or in connection with the software or the use or other dealings
# in the software.

use strict;
use warnings;

our $VERSION = '0.7.5';

use English;
use Getopt::Long;
use Pod::Usage;
use File::Copy;
use File::Path qw(make_path remove_tree);
use File::Temp qw(tempfile tempdir);
use File::Basename;
use File::Find;
use Cwd qw(abs_path getcwd);
require "syscall.ph";    ## no critic (Modules::RequireBarewordIncludes)
use Fcntl qw(S_IFCHR S_IFBLK FD_CLOEXEC F_GETFD F_SETFD);
use List::Util qw(any none);
use POSIX qw(SIGINT SIGHUP SIGPIPE SIGTERM SIG_BLOCK SIG_UNBLOCK strftime);
use Carp;
use Term::ANSIColor;
use Socket;
use Time::HiRes;
use version;

## no critic (InputOutput::RequireBriefOpen)

# from sched.h
# use typeglob constants because "use constant" has several drawback as
# explained in the documentation for the Readonly CPAN module
*CLONE_NEWNS                 = \0x20000;       # mount namespace
*CLONE_NEWUTS                = \0x4000000;     # utsname
*CLONE_NEWIPC                = \0x8000000;     # ipc
*CLONE_NEWUSER               = \0x10000000;    # user
*CLONE_NEWPID                = \0x20000000;    # pid
*CLONE_NEWNET                = \0x40000000;    # net
*_LINUX_CAPABILITY_VERSION_3 = \0x20080522;
*CAP_SYS_ADMIN               = \21;
our ($CLONE_NEWNS, $CLONE_NEWUTS, $CLONE_NEWIPC,
    $CLONE_NEWUSER, $CLONE_NEWPID, $CLONE_NEWNET,
    $_LINUX_CAPABILITY_VERSION_3, $CAP_SYS_ADMIN);

#<<<
# type codes:
#   0 -> normal file
#   1 -> hardlink
#   2 -> symlink
#   3 -> character special
#   4 -> block special
#   5 -> directory
my @devfiles = (
    # filename  mode      type link target        major  minor
    ["",        oct(755), 5,   '',                undef, undef],
    ["console", oct(666), 3,   '',                5,     1],
    ["fd",      oct(777), 2,   '/proc/self/fd',   undef, undef],
    ["full",    oct(666), 3,   '',                1,     7],
    ["null",    oct(666), 3,   '',                1,     3],
    ["ptmx",    oct(666), 3,   '',                5,     2],
    ["pts/",    oct(755), 5,   '',                undef, undef],
    ["random",  oct(666), 3,   '',                1,     8],
    ["shm/",    oct(755), 5,   '',                undef, undef],
    ["stderr",  oct(777), 2,   '/proc/self/fd/2', undef, undef],
    ["stdin",   oct(777), 2,   '/proc/self/fd/0', undef, undef],
    ["stdout",  oct(777), 2,   '/proc/self/fd/1', undef, undef],
    ["tty",     oct(666), 3,   '',                5,     0],
    ["urandom", oct(666), 3,   '',                1,     9],
    ["zero",    oct(666), 3,   '',                1,     5],
);
#>>>

# verbosity levels:
#   0 -> print nothing
#   1 -> normal output and progress bars
#   2 -> verbose output
#   3 -> debug output
my $verbosity_level = 1;

my $is_covering = !!(eval { Devel::Cover::get_coverage() });

# the reason why Perl::Critic warns about this is, that it suspects that the
# programmer wants to implement a test whether the terminal is interactive or
# not, in which case, complex interactions with the magic *ARGV indeed make it
# advisable to use IO::Interactive. In our case, we do not want to create an
# interactivity check but just want to check whether STDERR is opened to a tty,
# so our use of -t is fine and not "fragile and complicated" as is written in
# the description of InputOutput::ProhibitInteractiveTest. Also see
# https://github.com/Perl-Critic/Perl-Critic/issues/918
sub stderr_is_tty() {
    ## no critic (InputOutput::ProhibitInteractiveTest)
    if (-t STDERR) {
        return 1;
    } else {
        return 0;
    }
}

sub debug {
    if ($verbosity_level < 3) {
        return;
    }
    my $msg = shift;
    my ($package, $filename, $line) = caller;
    $msg = "D: $PID $line $msg";
    if (stderr_is_tty()) {
        $msg = colored($msg, 'clear');
    }
    print STDERR "$msg\n";
    return;
}

sub info {
    if ($verbosity_level == 0) {
        return;
    }
    my $msg = shift;
    if ($verbosity_level >= 3) {
        my ($package, $filename, $line) = caller;
        $msg = "$PID $line $msg";
    }
    $msg = "I: $msg";
    if (stderr_is_tty()) {
        $msg = colored($msg, 'green');
    }
    print STDERR "$msg\n";
    return;
}

sub warning {
    if ($verbosity_level == 0) {
        return;
    }
    my $msg = shift;
    $msg = "W: $msg";
    if (stderr_is_tty()) {
        $msg = colored($msg, 'bold yellow');
    }
    print STDERR "$msg\n";
    return;
}

sub error {
    # if error() is called with the string from a previous error() that was
    # caught inside an eval(), then the string will have a newline which we
    # are stripping here
    chomp(my $msg = shift);
    $msg = "E: $msg";
    if (stderr_is_tty()) {
        $msg = colored($msg, 'bold red');
    }
    if ($verbosity_level == 3) {
        croak $msg;    # produces a backtrace
    } else {
        die "$msg\n";
    }
}

# check whether a directory is mounted by comparing the device number of the
# directory itself with its parent
sub is_mountpoint {
    my $dir = shift;
    if (!-e $dir) {
        return 0;
    }
    my @a = stat "$dir/.";
    my @b = stat "$dir/..";
    # if the device number is different, then the directory must be mounted
    if ($a[0] != $b[0]) {
        return 1;
    }
    # if the inode number is the same, then the directory must be mounted
    if ($a[1] == $b[1]) {
        return 1;
    }
    return 0;
}

# tar cannot figure out the decompression program when receiving data on
# standard input, thus we do it ourselves. This is copied from tar's
# src/suffix.c
sub get_tar_compressor {
    my $filename = shift;
    if ($filename eq '-') {
        return;
    } elsif ($filename =~ /\.tar$/) {
        return;
    } elsif ($filename =~ /\.(gz|tgz|taz)$/) {
        return ['gzip'];
    } elsif ($filename =~ /\.(Z|taZ)$/) {
        return ['compress'];
    } elsif ($filename =~ /\.(bz2|tbz|tbz2|tz2)$/) {
        return ['bzip2'];
    } elsif ($filename =~ /\.lz$/) {
        return ['lzip'];
    } elsif ($filename =~ /\.(lzma|tlz)$/) {
        return ['lzma'];
    } elsif ($filename =~ /\.lzo$/) {
        return ['lzop'];
    } elsif ($filename =~ /\.lz4$/) {
        return ['lz4'];
    } elsif ($filename =~ /\.(xz|txz)$/) {
        return ['xz', '--threads=0'];
    } elsif ($filename =~ /\.zst$/) {
        return ['zstd'];
    }
    return;
}

sub test_unshare_userns {
    my $verbose = shift;
    if ($EFFECTIVE_USER_ID == 0) {
        my $msg = "cannot unshare user namespace when executing as root";
        if ($verbose) {
            warning $msg;
        } else {
            debug $msg;
        }
        return 0;
    }
    # arguments to syscalls have to be stored in their own variable or
    # otherwise we will get "Modification of a read-only value attempted"
    my $unshare_flags = $CLONE_NEWUSER;
    # we spawn a new per process because if unshare succeeds, we would
    # otherwise have unshared the mmdebstrap process itself which we don't want
    my $pid = fork() // error "fork() failed: $!";
    if ($pid == 0) {
        my $ret = syscall(&SYS_unshare, $unshare_flags);
        if ($ret == 0) {
            exit 0;
        } else {
            my $msg = "unshare syscall failed: $!";
            if ($verbose) {
                warning $msg;
            } else {
                debug $msg;
            }
            exit 1;
        }
    }
    waitpid($pid, 0);
    if (($? >> 8) != 0) {
        return 0;
    }
    # if newuidmap and newgidmap exist, the exit status will be 1 when
    # executed without parameters
    system "newuidmap 2>/dev/null";
    if (($? >> 8) != 1) {
        if (($? >> 8) == 127) {
            my $msg = "cannot find newuidmap";
            if ($verbose) {
                warning $msg;
            } else {
                debug $msg;
            }
        } else {
            my $msg = "newuidmap returned unknown exit status: $?";
            if ($verbose) {
                warning $msg;
            } else {
                debug $msg;
            }
        }
        return 0;
    }
    system "newgidmap 2>/dev/null";
    if (($? >> 8) != 1) {
        if (($? >> 8) == 127) {
            my $msg = "cannot find newgidmap";
            if ($verbose) {
                warning $msg;
            } else {
                debug $msg;
            }
        } else {
            my $msg = "newgidmap returned unknown exit status: $?";
            if ($verbose) {
                warning $msg;
            } else {
                debug $msg;
            }
        }
        return 0;
    }
    return 1;
}

sub read_subuid_subgid() {
    my $username = getpwuid $<;
    my ($subid, $num_subid, $fh, $n);
    my @result = ();

    if (!-e "/etc/subuid") {
        warning "/etc/subuid doesn't exist";
        return;
    }
    if (!-r "/etc/subuid") {
        warning "/etc/subuid is not readable";
        return;
    }

    open $fh, "<", "/etc/subuid"
      or error "cannot open /etc/subuid for reading: $!";
    while (my $line = <$fh>) {
        ($n, $subid, $num_subid) = split(/:/, $line, 3);
        last if ($n eq $username);
    }
    close $fh;
    push @result, ["u", 0, $subid, $num_subid];

    if (scalar(@result) < 1) {
        warning "/etc/subuid does not contain an entry for $username";
        return;
    }
    if (scalar(@result) > 1) {
        warning "/etc/subuid contains multiple entries for $username";
        return;
    }

    open $fh, "<", "/etc/subgid"
      or error "cannot open /etc/subgid for reading: $!";
    while (my $line = <$fh>) {
        ($n, $subid, $num_subid) = split(/:/, $line, 3);
        last if ($n eq $username);
    }
    close $fh;
    push @result, ["g", 0, $subid, $num_subid];

    if (scalar(@result) < 2) {
        warning "/etc/subgid does not contain an entry for $username";
        return;
    }
    if (scalar(@result) > 2) {
        warning "/etc/subgid contains multiple entries for $username";
        return;
    }

    return @result;
}

# This function spawns two child processes forming the following process tree
#
#   A
#   |
#  fork()
#   |  \
#   B   C
#   |   |
#   |  fork()
#   |   |  \
#   |   D   E
#   |   |   |
#   |unshare()
#   | close()
#   |   |   |
#   |   | read()
#   |   | newuidmap(D)
#   |   | newgidmap(D)
#   |   |  /
#   | waitpid()
#   |   |
#   |  fork()
#   |   |  \
#   |   F   G
#   |   |   |
#   |   |   exec()
#   |   |  /
#   | waitpid()
#   |  /
# waitpid()
#
# To better refer to each individual part, we give each process a new
# identifier after calling fork(). Process A is the main process. After
# executing fork() we call the parent and child B and C, respectively. This
# first fork() is done because we do not want to modify A. B then remains
# waiting for its child C to finish. C calls fork() again, splitting into
# the parent D and its child E. In the parent D we call unshare() and close a
# pipe shared by D and E to signal to E that D is done with calling unshare().
# E notices this by using read() and follows up with executing the tools
# new[ug]idmap on D. E finishes and D continues with doing another fork().
# This is because when unsharing the PID namespace, we need a PID 1 to be kept
# alive or otherwise any child processes cannot fork() anymore themselves. So
# we keep F as PID 1 and finally call exec() in G.
sub get_unshare_cmd {
    my $cmd   = shift;
    my $idmap = shift;

    # unsharing the mount namespace (NEWNS) requires CAP_SYS_ADMIN
    my $unshare_flags
      = $CLONE_NEWNS | $CLONE_NEWPID | $CLONE_NEWUTS | $CLONE_NEWIPC;

    # we only need to add CLONE_NEWUSER if we are not yet root
    if ($EFFECTIVE_USER_ID != 0) {
        $unshare_flags |= $CLONE_NEWUSER;
    }

    if (0) {
        $unshare_flags |= $CLONE_NEWNET;
    }

    # fork a new process and let the child get unshare()ed
    # we don't want to unshare the parent process
    my $gcpid = fork() // error "fork() failed: $!";
    if ($gcpid == 0) {
        # Create a pipe for the parent process to signal the child process that
        # it is done with calling unshare() so that the child can go ahead
        # setting up uid_map and gid_map.
        pipe my $rfh, my $wfh;
        # We have to do this dance with forking a process and then modifying
        # the parent from the child because:
        #  - new[ug]idmap can only be called on a process id after that process
        #    has unshared the user namespace
        #  - a process looses its capabilities if it performs an execve() with
        #    nonzero user ids see the capabilities(7) man page for details.
        #  - a process that unshared the user namespace by default does not
        #    have the privileges to call new[ug]idmap on itself
        #
        # this also works the other way around (the child setting up a user
        # namespace and being modified from the parent) but that way, the
        # parent would have to stay around until the child exited (so a pid
        # would be wasted). Additionally, that variant would require an
        # additional pipe to let the parent signal the child that it is done
        # with calling new[ug]idmap. The way it is done here, this signaling
        # can instead be done by wait()-ing for the exit of the child.

        my $ppid = $$;
        my $cpid = fork() // error "fork() failed: $!";
        if ($cpid == 0) {
            # child

            # Close the writing descriptor at our end of the pipe so that we
            # see EOF when parent closes its descriptor.
            close $wfh;

            # Wait for the parent process to finish its unshare() call by
            # waiting for an EOF.
            0 == sysread $rfh, my $c, 1 or error "read() did not receive EOF";

            # the process is already root, so no need for newuidmap/newgidmap
            if ($EFFECTIVE_USER_ID == 0) {
                exit 0;
            }

            # The program's new[ug]idmap have to be used because they are
            # setuid root.  These privileges are needed to map the ids from
            # /etc/sub[ug]id to the user namespace set up by the parent.
            # Without these privileges, only the id of the user itself can be
            # mapped into the new namespace.
            #
            # Since new[ug]idmap is setuid root we also don't need to write
            # "deny" to /proc/$$/setgroups beforehand (this is otherwise
            # required for unprivileged processes trying to write to
            # /proc/$$/gid_map since kernel version 3.19 for security reasons)
            # and therefore the parent process keeps its ability to change its
            # own group here.
            #
            # Since /proc/$ppid/[ug]id_map can only be written to once,
            # respectively, instead of making multiple calls to new[ug]idmap,
            # we assemble a command line that makes one call each.
            my $uidmapcmd = "";
            my $gidmapcmd = "";
            foreach (@{$idmap}) {
                my ($t, $hostid, $nsid, $range) = @{$_};
                if ($t ne "u" and $t ne "g" and $t ne "b") {
                    error "invalid idmap type: $t";
                }
                if ($t eq "u" or $t eq "b") {
                    $uidmapcmd .= " $hostid $nsid $range";
                }
                if ($t eq "g" or $t eq "b") {
                    $gidmapcmd .= " $hostid $nsid $range";
                }
            }
            my $idmapcmd = '';
            if ($uidmapcmd ne "") {
                0 == system "newuidmap $ppid $uidmapcmd"
                  or error "newuidmap $ppid $uidmapcmd failed: $!";
            }
            if ($gidmapcmd ne "") {
                0 == system "newgidmap $ppid $gidmapcmd"
                  or error "newgidmap $ppid $gidmapcmd failed: $!";
            }
            exit 0;
        }

        # parent

        # After fork()-ing, the parent immediately calls unshare...
        0 == syscall &SYS_unshare, $unshare_flags
          or error "unshare() failed: $!";

        # .. and then signals the child process that we are done with the
        # unshare() call by sending an EOF.
        close $wfh;

        # Wait for the child process to finish its setup by waiting for its
        # exit.
        $cpid == waitpid $cpid, 0 or error "waitpid() failed: $!";
        my $exit = $? >> 8;
        if ($exit != 0) {
            error "child had a non-zero exit status: $exit";
        }

        # Currently we are nobody (uid and gid are 65534). So we become root
        # user and group instead.
        #
        # We are using direct syscalls instead of setting $(, $), $< and $>
        # because then perl would do additional stuff which we don't need or
        # want here, like checking /proc/sys/kernel/ngroups_max (which might
        # not exist). It would also also call setgroups() in a way that makes
        # the root user be part of the group unknown.
        if ($EFFECTIVE_USER_ID != 0) {
            0 == syscall &SYS_setgid, 0 or error "setgid failed: $!";
            0 == syscall &SYS_setuid, 0 or error "setuid failed: $!";
            0 == syscall &SYS_setgroups, 0, 0 or error "setgroups failed: $!";
        }

        if (1) {
            # When the pid namespace is also unshared, then processes expect a
            # master pid to always be alive within the namespace. To achieve
            # this, we fork() here instead of exec() to always have one dummy
            # process running as pid 1 inside the namespace. This is also what
            # the unshare tool does when used with the --fork option.
            #
            # Otherwise, without a pid 1, new processes cannot be forked
            # anymore after pid 1 finished.
            my $cpid = fork() // error "fork() failed: $!";
            if ($cpid != 0) {
                # The parent process will stay alive as pid 1 in this
                # namespace until the child finishes executing. This is
                # important because pid 1 must never die or otherwise nothing
                # new can be forked.
                $cpid == waitpid $cpid, 0 or error "waitpid() failed: $!";
                exit($? >> 8);
            }
        }

        &{$cmd}();

        exit 0;
    }

    # parent
    return $gcpid;
}

sub havemknod {
    my $root      = shift;
    my $havemknod = 0;
    if (-e "$root/test-dev-null") {
        error "/test-dev-null already exists";
    }
  TEST: {
        # we fork so that we can read STDERR
        my $pid = open my $fh, '-|' // error "failed to fork(): $!";
        if ($pid == 0) {
            open(STDERR, '>&', STDOUT) or error "cannot open STDERR: $!";
            # we use mknod(1) instead of the system call because creating the
            # right dev_t argument requires makedev(3)
            exec 'mknod', "$root/test-dev-null", 'c', '1', '3';
        }
        chomp(
            my $content = do { local $/; <$fh> }
        );
        close $fh;
        {
            last TEST unless $? == 0 and $content eq '';
            last TEST unless -c "$root/test-dev-null";
            last TEST unless open my $fh, '>', "$root/test-dev-null";
            last TEST unless print $fh 'test';
        }
        $havemknod = 1;
    }
    if (-e "$root/test-dev-null") {
        unlink "$root/test-dev-null"
          or error "cannot unlink /test-dev-null: $!";
    }
    return $havemknod;
}

sub print_progress {
    if ($verbosity_level != 1) {
        return;
    }
    my $perc = shift;
    if (!stderr_is_tty()) {
        return;
    }
    if ($perc eq "done") {
        # \e[2K clears everything on the current line (i.e. the progress bar)
        print STDERR "\e[2Kdone\n";
        return;
    }
    if ($perc >= 100) {
        $perc = 100;
    }
    my $width = 50;
    my $num_x = int($perc * $width / 100);
    my $bar   = '=' x $num_x;
    if ($num_x != $width) {
        $bar .= '>';
        $bar .= ' ' x ($width - $num_x - 1);
    }
    printf STDERR "%6.2f [%s]\r", $perc, $bar;
    return;
}

sub run_progress {
    my ($get_exec, $line_handler, $line_has_error, $chdir) = @_;
    pipe my $rfh, my $wfh;
    my $got_signal = 0;
    my $ignore     = sub {
        info "run_progress() received signal $_[0]: waiting for child...";
    };

    debug("run_progress: exec " . (join ' ', ($get_exec->('${FD}'))));

    # delay signals so that we can fork and change behaviour of the signal
    # handler in parent and child without getting interrupted
    my $sigset = POSIX::SigSet->new(SIGINT, SIGHUP, SIGPIPE, SIGTERM);
    POSIX::sigprocmask(SIG_BLOCK, $sigset) or error "Can't block signals: $!";

    my $pid1 = open(my $pipe, '-|') // error "failed to fork(): $!";

    if ($pid1 == 0) {
        # child: default signal handlers
        local $SIG{'INT'}  = 'DEFAULT';
        local $SIG{'HUP'}  = 'DEFAULT';
        local $SIG{'PIPE'} = 'DEFAULT';
        local $SIG{'TERM'} = 'DEFAULT';

        # unblock all delayed signals (and possibly handle them)
        POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
          or error "Can't unblock signals: $!";

        close $rfh;
        # Unset the close-on-exec flag, so that the file descriptor does not
        # get closed when we exec
        my $flags = fcntl($wfh, F_GETFD, 0) or error "fcntl F_GETFD: $!";
        fcntl($wfh, F_SETFD, $flags & ~FD_CLOEXEC)
          or error "fcntl F_SETFD: $!";
        my $fd = fileno $wfh;
        # redirect stderr to stdout so that we can capture it
        open(STDERR, '>&', STDOUT) or error "cannot open STDOUT: $!";
        my @execargs = $get_exec->($fd);
        # before apt 1.5, "apt-get update" attempted to chdir() into the
        # working directory. This will fail if the current working directory
        # is not accessible by the user (for example in unshare mode). See
        # Debian bug #860738
        if (defined $chdir) {
            chdir $chdir or error "failed chdir() to $chdir: $!";
        }
        eval { Devel::Cover::set_coverage("none") } if $is_covering;
        exec { $execargs[0] } @execargs
          or error 'cannot exec() ' . (join ' ', @execargs);
    }
    close $wfh;

    # spawn two processes:
    #   parent will parse stdout to look for errors
    #   child will parse $rfh for the progress meter
    my $pid2 = fork() // error "failed to fork(): $!";
    if ($pid2 == 0) {
        # child: default signal handlers
        local $SIG{'INT'}  = 'IGNORE';
        local $SIG{'HUP'}  = 'IGNORE';
        local $SIG{'PIPE'} = 'IGNORE';
        local $SIG{'TERM'} = 'IGNORE';

        # unblock all delayed signals (and possibly handle them)
        POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
          or error "Can't unblock signals: $!";

        my $progress = 0.0;
        my $status   = undef;
        print_progress($progress);
        while (my $line = <$rfh>) {
            my ($newprogress, $newstatus) = $line_handler->($line);
            next unless $newprogress;
            # start a new line if the new progress value is less than the
            # previous one
            if ($newprogress < $progress) {
                print_progress("done");
            }
            if (defined $newstatus) {
                $status = $newstatus;
            }
            if (    defined $status
                and $verbosity_level == 1
                and stderr_is_tty()) {
                # \e[2K clears everything on the current line (i.e. the
                # progress bar)
                print STDERR "\e[2K$status: ";
            }
            print_progress($newprogress);
            $progress = $newprogress;
        }
        print_progress("done");

        exit 0;
    }

    # parent: ignore signals
    # by using "local", the original is automatically restored once the
    # function returns
    local $SIG{'INT'}  = $ignore;
    local $SIG{'HUP'}  = $ignore;
    local $SIG{'PIPE'} = $ignore;
    local $SIG{'TERM'} = $ignore;

    # unblock all delayed signals (and possibly handle them)
    POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
      or error "Can't unblock signals: $!";

    my $output    = '';
    my $has_error = 0;
    while (my $line = <$pipe>) {
        $has_error = $line_has_error->($line);
        if ($verbosity_level >= 2) {
            print STDERR $line;
        } else {
            # forward captured apt output
            $output .= $line;
        }
    }

    close($pipe);
    my $fail = 0;
    if ($? != 0 or $has_error) {
        $fail = 1;
    }

    waitpid $pid2, 0;
    $? == 0 or error "progress parsing failed";

    if ($got_signal) {
        error "run_progress() received signal: $got_signal";
    }

    # only print failure after progress output finished or otherwise it
    # might interfere with the remaining output
    if ($fail) {
        if ($verbosity_level >= 1) {
            print STDERR $output;
        }
        error((join ' ', $get_exec->('<$fd>')) . ' failed');
    }
    return;
}

sub run_dpkg_progress {
    my $options = shift;
    my @debs    = @{ $options->{PKGS} // [] };
    my $get_exec
      = sub { return @{ $options->{ARGV} }, "--status-fd=$_[0]", @debs; };
    my $line_has_error = sub { return 0; };
    my $num            = 0;
    # each package has one install and one configure step, thus the total
    # number is twice the number of packages
    my $total        = (scalar @debs) * 2;
    my $line_handler = sub {
        my $status = undef;
        if ($_[0] =~ /^processing: (install|configure): /) {
            if ($1 eq 'install') {
                $status = 'installing';
            } elsif ($1 eq 'configure') {
                $status = 'configuring';
            } else {
                error "unknown status: $1";
            }
            $num += 1;
        }
        return $num / $total * 100, $status;
    };
    run_progress $get_exec, $line_handler, $line_has_error;
    return;
}

sub run_apt_progress {
    my $options = shift;
    my @debs    = @{ $options->{PKGS} // [] };
    my $tmpedsp;
    if (exists $options->{EDSP_RES}) {
        (undef, $tmpedsp) = tempfile(
            "mmdebstrap.edsp.XXXXXXXXXXXX",
            OPEN   => 0,
            TMPDIR => 1
        );
    }
    my $get_exec = sub {