mmdebstrap/mmdebstrap

#!/usr/bin/perl
#
# Copyright: 2018 Johannes Schauer <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.

use strict;
use warnings;

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 Cwd qw(abs_path);
require "syscall.ph";
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);
use Carp;
use Term::ANSIColor;

# from sched.h
use constant {
    CLONE_NEWNS   => 0x20000,
    CLONE_NEWUTS  => 0x4000000,
    CLONE_NEWIPC  => 0x8000000,
    CLONE_NEWUSER => 0x10000000,
    CLONE_NEWPID  => 0x20000000,
    CLONE_NEWNET  => 0x40000000,
};

# 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
    [ "./dev/",        0755, 5,   '',                undef, undef ],
    [ "./dev/console", 0666, 3,   '',                5,     1 ],
    [ "./dev/fd",      0777, 2,   '/proc/self/fd',   undef, undef ],
    [ "./dev/full",    0666, 3,   '',                1,     7 ],
    [ "./dev/null",    0666, 3,   '',                1,     3 ],
    [ "./dev/ptmx",    0666, 3,   '',                5,     2 ],
    [ "./dev/pts/",    0755, 5,   '',                undef, undef ],
    [ "./dev/random",  0666, 3,   '',                1,     8 ],
    [ "./dev/shm/",    0755, 5,   '',                undef, undef ],
    [ "./dev/stderr",  0777, 2,   '/proc/self/fd/2', undef, undef ],
    [ "./dev/stdin",   0777, 2,   '/proc/self/fd/0', undef, undef ],
    [ "./dev/stdout",  0777, 2,   '/proc/self/fd/1', undef, undef ],
    [ "./dev/tty",     0666, 3,   '',                5,     0 ],
    [ "./dev/urandom", 0666, 3,   '',                1,     9 ],
    [ "./dev/zero",    0666, 3,   '',                1,     5 ],
);

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

sub debug {
    if ($verbosity_level < 3) {
	return;
    }
    my $msg = shift;
    $msg = "D: $msg";
    if ( -t STDERR ) {
	$msg = colored($msg, 'clear')
    }
    print STDERR "$msg\n";
}

sub info {
    if ($verbosity_level == 0) {
	return;
    }
    my $msg = shift;
    $msg = "I: $msg";
    if ( -t STDERR ) {
	$msg = colored($msg, 'green')
    }
    print STDERR "$msg\n";
}

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

sub error {
    if ($verbosity_level == 0) {
	return;
    }
    # 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 ( -t STDERR ) {
	$msg = colored($msg, 'bold red')
    }
    if ($verbosity_level == 3) {
	croak $msg; # produces a backtrace
    } else {
	die "$msg\n";
    }
}

# 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 undef
    } elsif ($filename =~ /\.tar$/) {
	return undef
    } 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';
    } elsif ($filename =~ /\.zst$/) {
	return 'zstd';
    }
    return undef
}

sub test_unshare($) {
    my $verbose = shift;
    if ($EFFECTIVE_USER_ID == 0) {
	my $msg = "cannot use unshare mode 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;

    my $unshare_flags = CLONE_NEWUSER | CLONE_NEWNS | CLONE_NEWPID | CLONE_NEWUTS | CLONE_NEWIPC;

    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 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.
	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);
	    # 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 (!-t STDERR) {
	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;
}

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

    # 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
	$SIG{'INT'} = 'DEFAULT';
	$SIG{'HUP'} = 'DEFAULT';
	$SIG{'PIPE'} = 'DEFAULT';
	$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);
	my @execargs = $get_exec->($fd);
	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
	$SIG{'INT'} = 'IGNORE';
	$SIG{'HUP'} = 'IGNORE';
	$SIG{'PIPE'} = 'IGNORE';
	$SIG{'TERM'} = 'IGNORE';

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

	print_progress 0.0;
	while (my $line = <$rfh>) {
	    my $output = $line_handler->($line);
	    next unless $output;
	    print_progress $output;
	}
	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');
    }
}

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 {
	if ($_[0] =~ /^processing: (install|configure): /) {
	    $num += 1;
	}
	return $num/$total*100;
    };
    run_progress $get_exec, $line_handler, $line_has_error;
}

sub run_apt_progress {
    my $options = shift;
    my @debs = @{$options->{PKGS} // []};
    my $get_exec = sub {
	return (
	    @{$options->{ARGV}},
	    "-oAPT::Status-Fd=$_[0]",
	    # prevent apt from messing up the terminal and allow dpkg to
	    # receive SIGINT and quit immediately without waiting for
	    # maintainer script to finish
	    '-oDpkg::Use-Pty=false',
	    @debs
	)};
    my $line_has_error = sub {
	# apt-get doesn't report a non-zero exit if the update failed. Thus, we
	# have to parse its output. See #778357, #776152, #696335 and #745735
	if ($_[0] =~ /^(W: |Err:)/) {
	    return 1;
	}
	return 0;
    };
    my $line_handler = sub {
	if ($_[0] =~ /(pmstatus|dlstatus):[^:]+:(\d+\.\d+):.*/) {
	    return $2;
	}
    };
    run_progress $get_exec, $line_handler, $line_has_error;
}

sub run_chroot(&$) {
    my $cmd = shift;
    my $options = shift;

    my @cleanup_tasks = ();

    my $cleanup = sub {
	my $signal = $_[0];
	while (my $task = pop @cleanup_tasks) {
	    $task->();
	}
	if ($signal) {
	    warning "pid $PID cought signal: $signal";
	    exit 1;
	}
    };

    local $SIG{INT} = $cleanup;
    local $SIG{HUP} = $cleanup;
    local $SIG{PIPE} = $cleanup;
    local $SIG{TERM} = $cleanup;

    eval {
	if (any { $_ eq $options->{mode} } ('root', 'unshare')) {
	    # if more than essential should be installed, make the system look
	    # more like a real one by creating or bind-mounting the device nodes
	    foreach my $file (@devfiles) {
		my ($fname, $mode, $type, $linkname, $devmajor, $devminor) = @{$file};
		next if $fname eq './dev/';
		if ($type == 0) { # normal file
		    error "type 0 not implemented";
		} elsif ($type == 1) { # hardlink
		    error "type 1 not implemented";
		} elsif ($type == 2) { # symlink
		    if (!$options->{havemknod}) {
			if ($options->{mode} eq 'fakechroot' and $linkname =~ /^\/proc/) {
			    # there is no /proc in fakechroot mode
			    next;
			}
			if (any { $_ eq $options->{mode} } ('root', 'unshare')) {
			    push @cleanup_tasks, sub {
				unlink "$options->{root}/$fname" or warn "cannot unlink $fname: $!";
			    }
			}
			symlink $linkname, "$options->{root}/$fname" or error "cannot create symlink $fname";
		    }
		} elsif ($type == 3 or $type == 4) { # character/block special
		    if (!$options->{havemknod}) {
			open my $fh, '>', "$options->{root}/$fname" or error "cannot open $options->{root}/$fname: $!";
			close $fh;
			if ($options->{mode} eq 'unshare') {
			    push @cleanup_tasks, sub {
				0 == system('umount', '--no-mtab', "$options->{root}/$fname") or warn "umount $fname failed: $?";
				unlink "$options->{root}/$fname" or warn "cannot unlink $fname: $!";
			    };
			} elsif ($options->{mode} eq 'root') {
			    push @cleanup_tasks, sub {
				0 == system('umount', "$options->{root}/$fname") or warn "umount failed: $?";
				unlink "$options->{root}/$fname" or warn "cannot unlink $fname: $!";
			    };
			} else {
			    error "unknown mode: $options->{mode}";
			}
			0 == system('mount', '-o', 'bind', "/$fname", "$options->{root}/$fname") or error "mount $fname failed: $?";
		    }
		} elsif ($type == 5) { # directory
		    if (!$options->{havemknod}) {
			if (any { $_ eq $options->{mode} } ('root', 'unshare')) {
			    push @cleanup_tasks, sub {
				rmdir "$options->{root}/$fname" or warn "cannot rmdir $fname: $!";
			    }
			}
			make_path "$options->{root}/$fname" or error "cannot make_path $fname";
			chmod $mode, "$options->{root}/$fname" or error "cannot chmod $fname: $!";
		    }
		    if ($options->{mode} eq 'unshare') {
			push @cleanup_tasks, sub {
			    0 == system('umount', '--no-mtab', "$options->{root}/$fname") or warn "umount $fname failed: $?";
			};
		    } elsif ($options->{mode} eq 'root') {
			push @cleanup_tasks, sub {
			    0 == system('umount', "$options->{root}/$fname") or warn "umount $fname failed: $?";
			};
		    } else {
			error "unknown mode: $options->{mode}";
		    }
		    0 == system('mount', '-o', 'bind', "/$fname", "$options->{root}/$fname") or error "mount $fname failed: $?";
		} else {
		    error "unsupported type: $type";
		}
	    }
	} elsif (any { $_ eq $options->{mode} } ('proot', 'fakechroot')) {
	    # we cannot mount in fakechroot and proot mode
	    # in proot mode we have /dev bind-mounted already through --bind=/dev
	} else {
	    error "unknown mode: $options->{mode}";
	}
	# We can only mount /proc and /sys after extracting the essential
	# set because if we mount it before, then base-files will not be able
	# to extract those
	if ($options->{mode} eq 'root') {
	    push @cleanup_tasks, sub {
		0 == system('umount', "$options->{root}/sys") or warn "umount /sys failed: $?";
	    };
	    0 == system('mount', '-t', 'sysfs', '-o', 'nosuid,nodev,noexec', 'sys', "$options->{root}/sys") or error "mount /sys failed: $?";
	} elsif ($options->{mode} eq 'unshare') {
	    # naturally we have to clean up after ourselves in sudo mode where we
	    # do a real mount. But we also need to unmount in unshare mode because
	    # otherwise, even with the --one-file-system tar option, the
	    # permissions of the mount source will be stored and not the mount
	    # target (the directory)
	    push @cleanup_tasks, sub {
		# since we cannot write to /etc/mtab we need --no-mtab
		# unmounting /sys only seems to be successful with --lazy
		0 == system('umount', '--no-mtab', '--lazy', "$options->{root}/sys") or warn "umount /sys failed: $?";
	    };
	    # without the network namespace unshared, we cannot mount a new
	    # sysfs. Since we need network, we just bind-mount.
	    #
	    # we have to rbind because just using bind results in "wrong fs
	    # type, bad option, bad superblock" error
	    0 == system('mount', '-o', 'rbind', '/sys', "$options->{root}/sys") or error "mount /sys failed: $?";
	} elsif (any { $_ eq $options->{mode} } ('proot', 'fakechroot')) {
	    # we cannot mount in fakechroot and proot mode
	    # in proot mode we have /proc bind-mounted already through --bind=/proc
	} else {
	    error "unknown mode: $options->{mode}";
	}
	if ($options->{mode} eq 'root') {
	    push @cleanup_tasks, sub {
		0 == system('umount', "$options->{root}/proc") or error "umount /proc failed: $?";
	    };
	    0 == system('mount', '-t', 'proc', 'proc', "$options->{root}/proc") or error "mount /proc failed: $?";
	} elsif ($options->{mode} eq 'unshare') {
	    # naturally we have to clean up after ourselves in sudo mode where we
	    # do a real mount. But we also need to unmount in unshare mode because
	    # otherwise, even with the --one-file-system tar option, the
	    # permissions of the mount source will be stored and not the mount
	    # target (the directory)
	    push @cleanup_tasks, sub {
		# since we cannot write to /etc/mtab we need --no-mtab
		0 == system('umount', '--no-mtab', "$options->{root}/proc") or error "umount /proc failed: $?";
	    };
	    0 == system('mount', '-t', 'proc', 'proc', "$options->{root}/proc") or error "mount /proc failed: $?";
	} elsif (any { $_ eq $options->{mode} } ('proot', 'fakechroot')) {
	    # we cannot mount in fakechroot and proot mode
	    # in proot mode we have /sys bind-mounted already through --bind=/sys
	} else {
	    error "unknown mode: $options->{mode}";
	}

	# prevent daemons from starting
	{
	    open my $fh, '>', "$options->{root}/usr/sbin/policy-rc.d" or error "cannot open policy-rc.d: $!";
	    print $fh "#!/bin/sh\n";
	    print $fh "exit 101\n";
	    close $fh;
	    chmod 0755, "$options->{root}/usr/sbin/policy-rc.d" or error "cannot chmod policy-rc.d: $!";
	}

	{
	    move("$options->{root}/sbin/start-stop-daemon", "$options->{root}/sbin/start-stop-daemon.REAL") or error "cannot move start-stop-daemon";
	    open my $fh, '>', "$options->{root}/sbin/start-stop-daemon" or error "cannot open policy-rc.d: $!";
	    print $fh "#!/bin/sh\n";
	    print $fh "echo \"Warning: Fake start-stop-daemon called, doing nothing\">&2\n";
	    close $fh;
	    chmod 0755, "$options->{root}/sbin/start-stop-daemon" or error "cannot chmod start-stop-daemon: $!";
	}

	&{$cmd}();

	# cleanup
	move("$options->{root}/sbin/start-stop-daemon.REAL", "$options->{root}/sbin/start-stop-daemon") or error "cannot move start-stop-daemon";
	unlink "$options->{root}/usr/sbin/policy-rc.d" or error "cannot unlink policy-rc.d";

    };

    my $error = $@;

    # we use the cleanup function to do the unmounting
    $cleanup->(0);

    if ($error) {
	error "run_chroot failed: $error";
    }
}

sub run_hooks($$) {
    my $name = shift;
    my $options = shift;

    if (scalar @{$options->{"${name}_hook"}} == 0) {
	return;
    }

    my $runner = sub {
	foreach my $script (@{$options->{"${name}_hook"}}) {
	    if ( -x $script || $script !~ m/[^\w@\%+=:,.\/-]/a) {
		info "running --$name-hook directly: $script $options->{root}";
		# execute it directly if it's an executable file
		# or if it there are no shell metacharacters
		# (the /a regex modifier makes \w match only ASCII)
		0 == system($script, $options->{root}) or error "command failed: $script";
	    } else {
		info "running --$name-hook in shell: sh -c '$script' exec $options->{root}";
		# otherwise, wrap everything in sh -c
		0 == system('sh', '-c', $script, 'exec', $options->{root}) or error "command failed: $script";
	    }
	}
    };

    if ($name eq 'setup') {
	# execute directly without mounting anything (the mount points do not
	# exist yet)
	&{$runner}();
    } else {
	run_chroot \&$runner, $options;
    }

}

sub setup {
    my $options = shift;