josch/mmdebstrap
2
3
Fork 6
Code Issues 8 Pull requests 1 Projects Releases Wiki Activity

coverage.sh: test with perlcritic

Browse source
This commit is contained in:
Johannes 'josch' Schauer 2020-01-09 08:39:40 +01:00
parent 4ba82a41cf
commit f867384c20
Signed by: josch
GPG key ID: F2CBA5C78FBD83E1
2 changed files with 252 additions and 191 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
coverage.sh
View file

@ -12,6 +12,13 @@ if [ "$ret" -ne 0 ]; then
fi fi
rm mmdebstrap.tdy rm mmdebstrap.tdy
if [ $(wc -L < mmdebstrap) -gt 79 ]; then
echo "exceeded maximum line length of 79 characters" >&2
exit 1
fi
perlcritic --severity 4 --verbose 8 mmdebstrap
mirrordir="./shared/cache/debian" mirrordir="./shared/cache/debian"
if [ ! -e "$mirrordir" ]; then if [ ! -e "$mirrordir" ]; then

436
mmdebstrap
View file

@ -33,7 +33,7 @@ use File::Path qw(make_path remove_tree);
use File::Temp qw(tempfile tempdir); use File::Temp qw(tempfile tempdir);
use File::Basename; use File::Basename;
use Cwd qw(abs_path); use Cwd qw(abs_path);
require "syscall.ph"; require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
use Fcntl qw(S_IFCHR S_IFBLK FD_CLOEXEC F_GETFD F_SETFD); use Fcntl qw(S_IFCHR S_IFBLK FD_CLOEXEC F_GETFD F_SETFD);
use List::Util qw(any none); use List::Util qw(any none);
use POSIX qw(SIGINT SIGHUP SIGPIPE SIGTERM SIG_BLOCK SIG_UNBLOCK); use POSIX qw(SIGINT SIGHUP SIGPIPE SIGTERM SIG_BLOCK SIG_UNBLOCK);
@ -41,15 +41,21 @@ use Carp;
use Term::ANSIColor; use Term::ANSIColor;
use Socket; use Socket;
## no critic (InputOutput::RequireBriefOpen)
# from sched.h # from sched.h
use constant { # use typeglob constants because "use constant" has several drawback as
CLONE_NEWNS => 0x20000, # explained in the documentation for the Readonly CPAN module
CLONE_NEWUTS => 0x4000000, *CLONE_NEWNS = \0x20000;
CLONE_NEWIPC => 0x8000000, *CLONE_NEWUTS = \0x4000000;
CLONE_NEWUSER => 0x10000000, *CLONE_NEWIPC = \0x8000000;
CLONE_NEWPID => 0x20000000, *CLONE_NEWUSER = \0x10000000;
CLONE_NEWNET => 0x40000000, *CLONE_NEWPID = \0x20000000;
}; *CLONE_NEWNET = \0x40000000;
our (
$CLONE_NEWNS, $CLONE_NEWUTS, $CLONE_NEWIPC,
$CLONE_NEWUSER, $CLONE_NEWPID, $CLONE_NEWNET
);
# type codes: # type codes:
# 0 -> normal file # 0 -> normal file
@ -60,21 +66,21 @@ use constant {
# 5 -> directory # 5 -> directory
my @devfiles = ( my @devfiles = (
# filename mode type link target major minor # filename mode type link target major minor
["./dev/", 0755, 5, '', undef, undef], ["./dev/", oct(755), 5, '', undef, undef],
["./dev/console", 0666, 3, '', 5, 1], ["./dev/console", oct(666), 3, '', 5, 1],
["./dev/fd", 0777, 2, '/proc/self/fd', undef, undef], ["./dev/fd", oct(777), 2, '/proc/self/fd', undef, undef],
["./dev/full", 0666, 3, '', 1, 7], ["./dev/full", oct(666), 3, '', 1, 7],
["./dev/null", 0666, 3, '', 1, 3], ["./dev/null", oct(666), 3, '', 1, 3],
["./dev/ptmx", 0666, 3, '', 5, 2], ["./dev/ptmx", oct(666), 3, '', 5, 2],
["./dev/pts/", 0755, 5, '', undef, undef], ["./dev/pts/", oct(755), 5, '', undef, undef],
["./dev/random", 0666, 3, '', 1, 8], ["./dev/random", oct(666), 3, '', 1, 8],
["./dev/shm/", 0755, 5, '', undef, undef], ["./dev/shm/", oct(755), 5, '', undef, undef],
["./dev/stderr", 0777, 2, '/proc/self/fd/2', undef, undef], ["./dev/stderr", oct(777), 2, '/proc/self/fd/2', undef, undef],
["./dev/stdin", 0777, 2, '/proc/self/fd/0', undef, undef], ["./dev/stdin", oct(777), 2, '/proc/self/fd/0', undef, undef],
["./dev/stdout", 0777, 2, '/proc/self/fd/1', undef, undef], ["./dev/stdout", oct(777), 2, '/proc/self/fd/1', undef, undef],
["./dev/tty", 0666, 3, '', 5, 0], ["./dev/tty", oct(666), 3, '', 5, 0],
["./dev/urandom", 0666, 3, '', 1, 9], ["./dev/urandom", oct(666), 3, '', 1, 9],
["./dev/zero", 0666, 3, '', 1, 5], ["./dev/zero", oct(666), 3, '', 1, 5],
); );
# verbosity levels: # verbosity levels:
@ -84,7 +90,7 @@ my @devfiles = (
# 3 -> debug output # 3 -> debug output
my $verbosity_level = 1; my $verbosity_level = 1;
my $is_covering = !!(eval 'Devel::Cover::get_coverage()'); my $is_covering = !!(eval { Devel::Cover::get_coverage() });
sub debug { sub debug {
if ($verbosity_level < 3) { if ($verbosity_level < 3) {
@ -93,10 +99,11 @@ sub debug {
my $msg = shift; my $msg = shift;
my ($package, $filename, $line) = caller; my ($package, $filename, $line) = caller;
$msg = "D: $PID $line $msg"; $msg = "D: $PID $line $msg";
if (-t STDERR) { if (-t STDERR) { ## no critic (InputOutput::ProhibitInteractiveTest)
$msg = colored($msg, 'clear'); $msg = colored($msg, 'clear');
} }
print STDERR "$msg\n"; print STDERR "$msg\n";
return;
} }
sub info { sub info {
@ -109,10 +116,11 @@ sub info {
$msg = "$PID $line $msg"; $msg = "$PID $line $msg";
} }
$msg = "I: $msg"; $msg = "I: $msg";
if (-t STDERR) { if (-t STDERR) { ## no critic (InputOutput::ProhibitInteractiveTest)
$msg = colored($msg, 'green'); $msg = colored($msg, 'green');
} }
print STDERR "$msg\n"; print STDERR "$msg\n";
return;
} }
sub warning { sub warning {
@ -121,10 +129,11 @@ sub warning {
} }
my $msg = shift; my $msg = shift;
$msg = "W: $msg"; $msg = "W: $msg";
if (-t STDERR) { if (-t STDERR) { ## no critic (InputOutput::ProhibitInteractiveTest)
$msg = colored($msg, 'bold yellow'); $msg = colored($msg, 'bold yellow');
} }
print STDERR "$msg\n"; print STDERR "$msg\n";
return;
} }
sub error { sub error {
@ -136,11 +145,11 @@ sub error {
# are stripping here # are stripping here
chomp(my $msg = shift); chomp(my $msg = shift);
$msg = "E: $msg"; $msg = "E: $msg";
if (-t STDERR) { if (-t STDERR) { ## no critic (InputOutput::ProhibitInteractiveTest)
$msg = colored($msg, 'bold red'); $msg = colored($msg, 'bold red');
} }
if ($verbosity_level == 3) { if ($verbosity_level == 3) {
croak $msg; # produces a backtrace croak $msg; # produces a backtrace
} else { } else {
die "$msg\n"; die "$msg\n";
} }
@ -148,7 +157,7 @@ sub error {
# check whether a directory is mounted by comparing the device number of the # check whether a directory is mounted by comparing the device number of the
# directory itself with its parent # directory itself with its parent
sub is_mountpoint($) { sub is_mountpoint {
my $dir = shift; my $dir = shift;
if (!-e $dir) { if (!-e $dir) {
return 0; return 0;
@ -169,12 +178,12 @@ sub is_mountpoint($) {
# tar cannot figure out the decompression program when receiving data on # tar cannot figure out the decompression program when receiving data on
# standard input, thus we do it ourselves. This is copied from tar's # standard input, thus we do it ourselves. This is copied from tar's
# src/suffix.c # src/suffix.c
sub get_tar_compressor($) { sub get_tar_compressor {
my $filename = shift; my $filename = shift;
if ($filename eq '-') { if ($filename eq '-') {
return undef; return;
} elsif ($filename =~ /\.tar$/) { } elsif ($filename =~ /\.tar$/) {
return undef; return;
} elsif ($filename =~ /\.(gz|tgz|taz)$/) { } elsif ($filename =~ /\.(gz|tgz|taz)$/) {
return ['gzip']; return ['gzip'];
} elsif ($filename =~ /\.(Z|taZ)$/) { } elsif ($filename =~ /\.(Z|taZ)$/) {
@ -194,10 +203,10 @@ sub get_tar_compressor($) {
} elsif ($filename =~ /\.zst$/) { } elsif ($filename =~ /\.zst$/) {
return ['zstd']; return ['zstd'];
} }
return undef; return;
} }
sub test_unshare($) { sub test_unshare {
my $verbose = shift; my $verbose = shift;
if ($EFFECTIVE_USER_ID == 0) { if ($EFFECTIVE_USER_ID == 0) {
my $msg = "cannot use unshare mode when executing as root"; my $msg = "cannot use unshare mode when executing as root";
@ -210,12 +219,12 @@ sub test_unshare($) {
} }
# arguments to syscalls have to be stored in their own variable or # arguments to syscalls have to be stored in their own variable or
# otherwise we will get "Modification of a read-only value attempted" # otherwise we will get "Modification of a read-only value attempted"
my $unshare_flags = CLONE_NEWUSER; my $unshare_flags = $CLONE_NEWUSER;
# we spawn a new per process because if unshare succeeds, we would # we spawn a new per process because if unshare succeeds, we would
# otherwise have unshared the mmdebstrap process itself which we don't want # otherwise have unshared the mmdebstrap process itself which we don't want
my $pid = fork() // error "fork() failed: $!"; my $pid = fork() // error "fork() failed: $!";
if ($pid == 0) { if ($pid == 0) {
my $ret = syscall &SYS_unshare, $unshare_flags; my $ret = syscall(&SYS_unshare, $unshare_flags);
if ($ret == 0) { if ($ret == 0) {
exit 0; exit 0;
} else { } else {
@ -371,16 +380,16 @@ sub read_subuid_subgid() {
# This is because when unsharing the PID namespace, we need a PID 1 to be kept # 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 # alive or otherwise any child processes cannot fork() anymore themselves. So
# we keep F as PID 1 and finally call exec() in G. # we keep F as PID 1 and finally call exec() in G.
sub get_unshare_cmd(&$) { sub get_unshare_cmd {
my $cmd = shift; my $cmd = shift;
my $idmap = shift; my $idmap = shift;
my $unshare_flags my $unshare_flags
= CLONE_NEWUSER | CLONE_NEWNS | CLONE_NEWPID | CLONE_NEWUTS = $CLONE_NEWUSER | $CLONE_NEWNS | $CLONE_NEWPID | $CLONE_NEWUTS
| CLONE_NEWIPC; | $CLONE_NEWIPC;
if (0) { if (0) {
$unshare_flags |= CLONE_NEWNET; $unshare_flags |= $CLONE_NEWNET;
} }
# fork a new process and let the child get unshare()ed # fork a new process and let the child get unshare()ed
@ -522,7 +531,7 @@ sub get_unshare_cmd(&$) {
return $gcpid; return $gcpid;
} }
sub havemknod($) { sub havemknod {
my $root = shift; my $root = shift;
my $havemknod = 0; my $havemknod = 0;
if (-e "$root/test-dev-null") { if (-e "$root/test-dev-null") {
@ -561,7 +570,7 @@ sub print_progress {
return; return;
} }
my $perc = shift; my $perc = shift;
if (!-t STDERR) { if (!-t STDERR) { ## no critic (InputOutput::ProhibitInteractiveTest)
return; return;
} }
if ($perc eq "done") { if ($perc eq "done") {
@ -580,6 +589,7 @@ sub print_progress {
$bar .= ' ' x ($width - $num_x - 1); $bar .= ' ' x ($width - $num_x - 1);
} }
printf STDERR "%6.2f [%s]\r", $perc, $bar; printf STDERR "%6.2f [%s]\r", $perc, $bar;
return;
} }
sub run_progress { sub run_progress {
@ -599,10 +609,10 @@ sub run_progress {
if ($pid1 == 0) { if ($pid1 == 0) {
# child: default signal handlers # child: default signal handlers
$SIG{'INT'} = 'DEFAULT'; local $SIG{'INT'} = 'DEFAULT';
$SIG{'HUP'} = 'DEFAULT'; local $SIG{'HUP'} = 'DEFAULT';
$SIG{'PIPE'} = 'DEFAULT'; local $SIG{'PIPE'} = 'DEFAULT';
$SIG{'TERM'} = 'DEFAULT'; local $SIG{'TERM'} = 'DEFAULT';
# unblock all delayed signals (and possibly handle them) # unblock all delayed signals (and possibly handle them)
POSIX::sigprocmask(SIG_UNBLOCK, $sigset) POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
@ -625,7 +635,7 @@ sub run_progress {
if (defined $chdir) { if (defined $chdir) {
chdir $chdir or error "failed chdir() to $chdir: $!"; chdir $chdir or error "failed chdir() to $chdir: $!";
} }
eval 'Devel::Cover::set_coverage("none")' if $is_covering; eval { Devel::Cover::set_coverage("none") } if $is_covering;
exec { $execargs[0] } @execargs exec { $execargs[0] } @execargs
or error 'cannot exec() ' . (join ' ', @execargs); or error 'cannot exec() ' . (join ' ', @execargs);
} }
@ -637,22 +647,22 @@ sub run_progress {
my $pid2 = fork() // error "failed to fork(): $!"; my $pid2 = fork() // error "failed to fork(): $!";
if ($pid2 == 0) { if ($pid2 == 0) {
# child: default signal handlers # child: default signal handlers
$SIG{'INT'} = 'IGNORE'; local $SIG{'INT'} = 'IGNORE';
$SIG{'HUP'} = 'IGNORE'; local $SIG{'HUP'} = 'IGNORE';
$SIG{'PIPE'} = 'IGNORE'; local $SIG{'PIPE'} = 'IGNORE';
$SIG{'TERM'} = 'IGNORE'; local $SIG{'TERM'} = 'IGNORE';
# unblock all delayed signals (and possibly handle them) # unblock all delayed signals (and possibly handle them)
POSIX::sigprocmask(SIG_UNBLOCK, $sigset) POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
or error "Can't unblock signals: $!"; or error "Can't unblock signals: $!";
print_progress 0.0; print_progress(0.0);
while (my $line = <$rfh>) { while (my $line = <$rfh>) {
my $output = $line_handler->($line); my $output = $line_handler->($line);
next unless $output; next unless $output;
print_progress $output; print_progress($output);
} }
print_progress "done"; print_progress("done");
exit 0; exit 0;
} }
@ -702,6 +712,7 @@ sub run_progress {
} }
error((join ' ', $get_exec->('<$fd>')) . ' failed'); error((join ' ', $get_exec->('<$fd>')) . ' failed');
} }
return;
} }
sub run_dpkg_progress { sub run_dpkg_progress {
@ -721,6 +732,7 @@ sub run_dpkg_progress {
return $num / $total * 100; return $num / $total * 100;
}; };
run_progress $get_exec, $line_handler, $line_has_error; run_progress $get_exec, $line_handler, $line_has_error;
return;
} }
sub run_apt_progress { sub run_apt_progress {
@ -755,9 +767,10 @@ sub run_apt_progress {
} }
}; };
run_progress $get_exec, $line_handler, $line_has_error, $options->{CHDIR}; run_progress $get_exec, $line_handler, $line_has_error, $options->{CHDIR};
return;
} }
sub run_chroot(&$) { sub run_chroot {
my $cmd = shift; my $cmd = shift;
my $options = shift; my $options = shift;
@ -1044,9 +1057,10 @@ sub run_chroot(&$) {
if ($error) { if ($error) {
error "run_chroot failed: $error"; error "run_chroot failed: $error";
} }
return;
} }
sub run_hooks($$) { sub run_hooks {
my $name = shift; my $name = shift;
my $options = shift; my $options = shift;
@ -1123,9 +1137,9 @@ sub run_hooks($$) {
# exist yet) # exist yet)
&{$runner}(); &{$runner}();
} else { } else {
run_chroot \&$runner, $options; run_chroot(\&$runner, $options);
} }
return;
} }
sub setup { sub setup {
@ -1417,7 +1431,10 @@ sub setup {
# line arguments because configuration settings like Dir::Etc have already # line arguments because configuration settings like Dir::Etc have already
# been evaluated at the time that apt takes its command line arguments # been evaluated at the time that apt takes its command line arguments
# into account. # into account.
$ENV{"APT_CONFIG"} = "$tmpfile"; {
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{"APT_CONFIG"} = "$tmpfile";
}
# when apt-get update is run by the root user, then apt will attempt to # when apt-get update is run by the root user, then apt will attempt to
# drop privileges to the _apt user. This will fail if the _apt user does # drop privileges to the _apt user. This will fail if the _apt user does
@ -1440,8 +1457,10 @@ sub setup {
# setting PATH for chroot, ldconfig, start-stop-daemon... # setting PATH for chroot, ldconfig, start-stop-daemon...
if (defined $ENV{PATH} && $ENV{PATH} ne "") { if (defined $ENV{PATH} && $ENV{PATH} ne "") {
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{PATH} = "$ENV{PATH}:/usr/sbin:/usr/bin:/sbin:/bin"; $ENV{PATH} = "$ENV{PATH}:/usr/sbin:/usr/bin:/sbin:/bin";
} else { } else {
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{PATH} = "/usr/sbin:/usr/bin:/sbin:/bin"; $ENV{PATH} = "/usr/sbin:/usr/bin:/sbin:/bin";
} }
@ -1692,7 +1711,7 @@ sub setup {
if ($pid1 == 0) { if ($pid1 == 0) {
open(STDOUT, '>&', $wfh) or error "cannot open STDOUT: $!"; open(STDOUT, '>&', $wfh) or error "cannot open STDOUT: $!";
debug("running dpkg-deb --fsys-tarfile $options->{root}/$deb"); debug("running dpkg-deb --fsys-tarfile $options->{root}/$deb");
eval 'Devel::Cover::set_coverage("none")' if $is_covering; eval { Devel::Cover::set_coverage("none") } if $is_covering;
exec 'dpkg-deb', '--fsys-tarfile', "$options->{root}/$deb"; exec 'dpkg-deb', '--fsys-tarfile', "$options->{root}/$deb";
} }
my $pid2 = fork() // error "fork() failed: $!"; my $pid2 = fork() // error "fork() failed: $!";
@ -1700,7 +1719,7 @@ sub setup {
open(STDIN, '<&', $rfh) or error "cannot open STDIN: $!"; open(STDIN, '<&', $rfh) or error "cannot open STDIN: $!";
debug( "running tar -C $options->{root}" debug( "running tar -C $options->{root}"
. " --keep-directory-symlink --extract --file -"); . " --keep-directory-symlink --extract --file -");
eval 'Devel::Cover::set_coverage("none")' if $is_covering; eval { Devel::Cover::set_coverage("none") } if $is_covering;
exec 'tar', '-C', $options->{root}, exec 'tar', '-C', $options->{root},
'--keep-directory-symlink', '--extract', '--file', '-'; '--keep-directory-symlink', '--extract', '--file', '-';
} }
@ -1730,8 +1749,10 @@ sub setup {
# where it has to look for shared libraries # where it has to look for shared libraries
if (defined $ENV{QEMU_LD_PREFIX} if (defined $ENV{QEMU_LD_PREFIX}
&& $ENV{QEMU_LD_PREFIX} ne "") { && $ENV{QEMU_LD_PREFIX} ne "") {
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{QEMU_LD_PREFIX} = "$ENV{QEMU_LD_PREFIX}:$options->{root}"; $ENV{QEMU_LD_PREFIX} = "$ENV{QEMU_LD_PREFIX}:$options->{root}";
} else { } else {
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{QEMU_LD_PREFIX} = $options->{root}; $ENV{QEMU_LD_PREFIX} = $options->{root};
} }
} }
@ -1798,18 +1819,24 @@ sub setup {
push @fakechrootsubst, split /:/, push @fakechrootsubst, split /:/,
$ENV{FAKECHROOT_CMD_SUBST}; $ENV{FAKECHROOT_CMD_SUBST};
} }
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{FAKECHROOT_CMD_SUBST} = join ':', @fakechrootsubst; $ENV{FAKECHROOT_CMD_SUBST} = join ':', @fakechrootsubst;
} }
if (defined $ENV{FAKECHROOT_EXCLUDE_PATH} if (defined $ENV{FAKECHROOT_EXCLUDE_PATH}
&& $ENV{FAKECHROOT_EXCLUDE_PATH} ne "") { && $ENV{FAKECHROOT_EXCLUDE_PATH} ne "") {
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{FAKECHROOT_EXCLUDE_PATH} $ENV{FAKECHROOT_EXCLUDE_PATH}
= "$ENV{FAKECHROOT_EXCLUDE_PATH}:/dev:/proc:/sys"; = "$ENV{FAKECHROOT_EXCLUDE_PATH}:/dev:/proc:/sys";
} else { } else {
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{FAKECHROOT_EXCLUDE_PATH} = '/dev:/proc:/sys'; $ENV{FAKECHROOT_EXCLUDE_PATH} = '/dev:/proc:/sys';
} }
# workaround for long unix socket path if FAKECHROOT_BASE # workaround for long unix socket path if FAKECHROOT_BASE
# exceeds the limit of 108 bytes # exceeds the limit of 108 bytes
$ENV{FAKECHROOT_AF_UNIX_PATH} = "/tmp"; {
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{FAKECHROOT_AF_UNIX_PATH} = "/tmp";
}
{ {
my @ldsoconf = ('/etc/ld.so.conf'); my @ldsoconf = ('/etc/ld.so.conf');
opendir(my $dh, '/etc/ld.so.conf.d') opendir(my $dh, '/etc/ld.so.conf.d')
@ -1839,6 +1866,7 @@ sub setup {
} }
close $fh; close $fh;
} }
## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{LD_LIBRARY_PATH} = join ':', @ldlibpath; $ENV{LD_LIBRARY_PATH} = join ':', @ldlibpath;
} }
} }
@ -1869,15 +1897,6 @@ sub setup {
if ($options->{mode} eq 'proot') { if ($options->{mode} eq 'proot') {
push @chrootcmd, "--qemu=qemu-$options->{qemu}"; push @chrootcmd, "--qemu=qemu-$options->{qemu}";
} elsif ($options->{mode} eq 'fakechroot') { } elsif ($options->{mode} eq 'fakechroot') {
# The binfmt support on the outside is used, so qemu needs
# to know where it has to look for shared libraries
if (defined $ENV{QEMU_LD_PREFIX}
&& $ENV{QEMU_LD_PREFIX} ne "") {
$ENV{QEMU_LD_PREFIX}
= "$ENV{QEMU_LD_PREFIX}:$options->{root}";
} else {
$ENV{QEMU_LD_PREFIX} = $options->{root};
}
# Make sure that the fakeroot and fakechroot shared # Make sure that the fakeroot and fakechroot shared
# libraries exist for the right architecture # libraries exist for the right architecture
open my $fh, '-|', 'dpkg-architecture', '-a', open my $fh, '-|', 'dpkg-architecture', '-a',
@ -1887,7 +1906,7 @@ sub setup {
my $deb_host_multiarch = do { local $/; <$fh> } my $deb_host_multiarch = do { local $/; <$fh> }
); );
close $fh; close $fh;
if ($? != 0 or !$deb_host_multiarch) { if (($? != 0) or (!$deb_host_multiarch)) {
error "dpkg-architecture failed: $?"; error "dpkg-architecture failed: $?";
} }
my $fakechrootdir my $fakechrootdir
@ -1904,10 +1923,24 @@ sub setup {
. " Install libfakeroot:$options->{nativearch}" . " Install libfakeroot:$options->{nativearch}"
. " outside the chroot"; . " outside the chroot";
} }
# The rest of this block sets environment variables, so we
# have to add the "no critic" statement to stop perlcritic
# from complaining about setting global variables
## no critic (Variables::RequireLocalizedPunctuationVars)
# fakechroot only fills LD_LIBRARY_PATH with the # fakechroot only fills LD_LIBRARY_PATH with the
# directories of the host's architecture. We append the # directories of the host's architecture. We append the
# directories of the chroot architecture. # directories of the chroot architecture.
$ENV{LD_LIBRARY_PATH} .= ":$fakechrootdir:$fakerootdir"; $ENV{LD_LIBRARY_PATH}
= "$ENV{LD_LIBRARY_PATH}:$fakechrootdir:$fakerootdir";
# The binfmt support on the outside is used, so qemu needs
# to know where it has to look for shared libraries
if (defined $ENV{QEMU_LD_PREFIX}
&& $ENV{QEMU_LD_PREFIX} ne "") {
$ENV{QEMU_LD_PREFIX}
= "$ENV{QEMU_LD_PREFIX}:$options->{root}";
} else {
$ENV{QEMU_LD_PREFIX} = $options->{root};
}
} elsif (any { $_ eq $options->{mode} } ('root', 'unshare')) { } elsif (any { $_ eq $options->{mode} } ('root', 'unshare')) {
# other modes require a static qemu-user binary # other modes require a static qemu-user binary
my $qemubin = "/usr/bin/qemu-$options->{qemu}-static"; my $qemubin = "/usr/bin/qemu-$options->{qemu}-static";
@ -1968,17 +2001,19 @@ sub setup {
# into account and thus doesn't install them in the right order # into account and thus doesn't install them in the right order
# And the --predep-package option is broken: #539133 # And the --predep-package option is broken: #539133
info "installing packages..."; info "installing packages...";
run_chroot { run_chroot(
run_dpkg_progress({ sub {
ARGV => [ run_dpkg_progress({
@chrootcmd, 'env', ARGV => [
'--unset=TMPDIR', 'dpkg', @chrootcmd, 'env',
'--install', '--force-depends' '--unset=TMPDIR', 'dpkg',
], '--install', '--force-depends'
PKGS => \@essential_pkgs, ],
}); PKGS => \@essential_pkgs,
} });
$options; },
$options
);
# if the path-excluded option was added to the dpkg config, # if the path-excluded option was added to the dpkg config,
# reinstall all packages # reinstall all packages
@ -1986,7 +2021,7 @@ sub setup {
open(my $fh, '<', open(my $fh, '<',
"$options->{root}/etc/dpkg/dpkg.cfg.d/99mmdebstrap") "$options->{root}/etc/dpkg/dpkg.cfg.d/99mmdebstrap")
or error "cannot open /etc/dpkg/dpkg.cfg.d/99mmdebstrap: $!"; or error "cannot open /etc/dpkg/dpkg.cfg.d/99mmdebstrap: $!";
my $num_matches = grep /^path-exclude=/, <$fh>; my $num_matches = grep { /^path-exclude=/ } <$fh>;
close $fh; close $fh;
if ($num_matches > 0) { if ($num_matches > 0) {
# without --skip-same-version, dpkg will install the given # without --skip-same-version, dpkg will install the given
@ -2107,19 +2142,22 @@ sub setup {
} }
} }
run_chroot { run_chroot(
info "installing remaining packages inside the chroot..."; sub {
run_apt_progress({ info
ARGV => [ "installing remaining packages inside the chroot...";
@chrootcmd, 'env', run_apt_progress({
'--unset=APT_CONFIG', '--unset=TMPDIR', ARGV => [
'apt-get', '--yes', @chrootcmd, 'env',
'install' '--unset=APT_CONFIG', '--unset=TMPDIR',
], 'apt-get', '--yes',
PKGS => [@pkgs_to_install], 'install'
}); ],
} PKGS => [@pkgs_to_install],
$options; });
},
$options
);
} }
} else { } else {
@ -2192,6 +2230,7 @@ sub setup {
} }
closedir($dh); closedir($dh);
} }
return;
} }
# messages from process inside unshared namespace to the outside # messages from process inside unshared namespace to the outside
@ -2209,6 +2248,7 @@ sub checkokthx {
my ($len, $msg) = unpack("nA5", $buf); my ($len, $msg) = unpack("nA5", $buf);
if ($msg ne "okthx") { error "expected okthx but got: $msg"; } if ($msg ne "okthx") { error "expected okthx but got: $msg"; }
if ($len != 0) { error "expected no payload but got $len bytes"; } if ($len != 0) { error "expected no payload but got $len bytes"; }
return;
} }
sub main() { sub main() {
@ -2467,11 +2507,14 @@ sub main() {
$mtime = $ENV{SOURCE_DATE_EPOCH} + 0; $mtime = $ENV{SOURCE_DATE_EPOCH} + 0;
} }
$ENV{DEBIAN_FRONTEND} = 'noninteractive'; {
$ENV{DEBCONF_NONINTERACTIVE_SEEN} = 'true'; ## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{LC_ALL} = 'C.UTF-8'; $ENV{DEBIAN_FRONTEND} = 'noninteractive';
$ENV{LANGUAGE} = 'C.UTF-8'; $ENV{DEBCONF_NONINTERACTIVE_SEEN} = 'true';
$ENV{LANG} = 'C.UTF-8'; $ENV{LC_ALL} = 'C.UTF-8';
$ENV{LANGUAGE} = 'C.UTF-8';
$ENV{LANG} = 'C.UTF-8';
}
# copy ARGV because getopt modifies it # copy ARGV because getopt modifies it
my @ARGVORIG = @ARGV; my @ARGVORIG = @ARGV;
@ -2596,7 +2639,7 @@ sub main() {
if ($pid == 0) { if ($pid == 0) {
# with the FAKECHROOT_DETECT environment variable set, any program # with the FAKECHROOT_DETECT environment variable set, any program
# execution will be replaced with the output "fakeroot [version]" # execution will be replaced with the output "fakeroot [version]"
$ENV{FAKECHROOT_DETECT} = 0; local $ENV{FAKECHROOT_DETECT} = 0;
exec 'echo', 'If fakechroot is running, this will not be printed'; exec 'echo', 'If fakechroot is running, this will not be printed';
} }
my $content = do { local $/; <$rfh> }; my $content = do { local $/; <$rfh> };
@ -2752,8 +2795,9 @@ sub main() {
my $pid = open my $fh, '-|' // error "failed to fork(): $!"; my $pid = open my $fh, '-|' // error "failed to fork(): $!";
if ($pid == 0) { if ($pid == 0) {
{ {
no warnings ## no critic (TestingAndDebugging::ProhibitNoWarnings)
; # don't print a warning if the following fails # don't print a warning if the following fails
no warnings;
exec 'arch-test', $options->{nativearch}; exec 'arch-test', $options->{nativearch};
} }
# if exec didn't work (for example because the arch-test # if exec didn't work (for example because the arch-test
@ -2775,8 +2819,9 @@ sub main() {
my $pid = open my $fh, '-|' // error "failed to fork(): $!"; my $pid = open my $fh, '-|' // error "failed to fork(): $!";
if ($pid == 0) { if ($pid == 0) {
{ {
no warnings ## no critic (TestingAndDebugging::ProhibitNoWarnings)
; # don't print a warning if the following fails # don't print a warning if the following fails
no warnings;
exec 'arch-test', '-n', $options->{nativearch}; exec 'arch-test', '-n', $options->{nativearch};
} }
# if exec didn't work (for example because the arch-test # if exec didn't work (for example because the arch-test
@ -2807,7 +2852,7 @@ sub main() {
{ {
open my $fh, '<', '/proc/filesystems' open my $fh, '<', '/proc/filesystems'
or error "failed to open /proc/filesystems: $!"; or error "failed to open /proc/filesystems: $!";
unless (grep /^nodev\tbinfmt_misc$/, (<$fh>)) { unless (grep { /^nodev\tbinfmt_misc$/ } (<$fh>)) {
warning "binfmt_misc not found in /proc/filesystems --" warning "binfmt_misc not found in /proc/filesystems --"
. " is the module loaded?"; . " is the module loaded?";
} }
@ -2817,9 +2862,11 @@ sub main() {
open my $fh, '<', '/proc/mounts' open my $fh, '<', '/proc/mounts'
or error "failed to open /proc/mounts: $!"; or error "failed to open /proc/mounts: $!";
unless ( unless (
grep grep {
/^binfmt_misc \/proc\/sys\/fs\/binfmt_misc binfmt_misc/, /^binfmt_misc
(<$fh>) \/proc\/sys\/fs\/binfmt_misc
binfmt_misc/x
} (<$fh>)
) { ) {
warning "binfmt_misc not found in /proc/mounts -- not" warning "binfmt_misc not found in /proc/mounts -- not"
. " mounted?"; . " mounted?";
@ -2890,7 +2937,7 @@ sub main() {
# If no suite was specified, then the whole sources.list has to # If no suite was specified, then the whole sources.list has to
# come from standard input # come from standard input
info "Reading sources.list from standard input..."; info "Reading sources.list from standard input...";
$sourceslist = do { local $/; <STDIN> }; $sourceslist = do { local $/; <> };
} else { } else {
my @components = (); my @components = ();
foreach my $comp (@{ $options->{components} }) { foreach my $comp (@{ $options->{components} }) {
@ -3050,7 +3097,7 @@ sub main() {
for my $arg (@ARGV) { for my $arg (@ARGV) {
if ($arg eq '-') { if ($arg eq '-') {
info "Reading sources.list from standard input..."; info "Reading sources.list from standard input...";
$sourceslist .= do { local $/; <STDIN> }; $sourceslist .= do { local $/; <> };
} elsif ($arg =~ /^deb(-src)? /) { } elsif ($arg =~ /^deb(-src)? /) {
$sourceslist .= "$arg\n"; $sourceslist .= "$arg\n";
} elsif ($arg =~ /:\/\//) { } elsif ($arg =~ /:\/\//) {
@ -3284,12 +3331,13 @@ sub main() {
my $outer_gid = $REAL_GROUP_ID + 0; my $outer_gid = $REAL_GROUP_ID + 0;
my $pid = get_unshare_cmd { chown 1, 1, $options->{root} } my $pid = get_unshare_cmd(
[ sub { chown 1, 1, $options->{root} },
['u', '0', $REAL_USER_ID, '1'], [
['g', '0', $outer_gid, '1'], ['u', '0', $REAL_USER_ID, '1'],
['u', '1', $idmap[0][2], '1'], ['g', '0', $outer_gid, '1'],
['g', '1', $idmap[1][2], '1']]; ['u', '1', $idmap[0][2], '1'],
['g', '1', $idmap[1][2], '1']]);
waitpid $pid, 0; waitpid $pid, 0;
$? == 0 or error "chown failed"; $? == 0 or error "chown failed";
} }
@ -3297,10 +3345,12 @@ sub main() {
# figure out whether we have mknod # figure out whether we have mknod
$options->{havemknod} = 0; $options->{havemknod} = 0;
if ($options->{mode} eq 'unshare') { if ($options->{mode} eq 'unshare') {
my $pid = get_unshare_cmd { my $pid = get_unshare_cmd(
$options->{havemknod} = havemknod($options->{root}); sub {
} $options->{havemknod} = havemknod($options->{root});
\@idmap; },
\@idmap
);
waitpid $pid, 0; waitpid $pid, 0;
$? == 0 or error "havemknod failed"; $? == 0 or error "havemknod failed";
} elsif ( } elsif (
@ -3366,60 +3416,62 @@ sub main() {
or error "socketpair failed: $!"; or error "socketpair failed: $!";
$options->{hooksock} = $childsock; $options->{hooksock} = $childsock;
if ($options->{mode} eq 'unshare') { if ($options->{mode} eq 'unshare') {
$pid = get_unshare_cmd { $pid = get_unshare_cmd(
# child sub {
$SIG{'INT'} = 'DEFAULT'; # child
$SIG{'HUP'} = 'DEFAULT'; local $SIG{'INT'} = 'DEFAULT';
$SIG{'PIPE'} = 'DEFAULT'; local $SIG{'HUP'} = 'DEFAULT';
$SIG{'TERM'} = 'DEFAULT'; local $SIG{'PIPE'} = 'DEFAULT';
local $SIG{'TERM'} = 'DEFAULT';
# unblock all delayed signals (and possibly handle them) # unblock all delayed signals (and possibly handle them)
POSIX::sigprocmask(SIG_UNBLOCK, $sigset) POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
or error "Can't unblock signals: $!"; or error "Can't unblock signals: $!";
close $rfh; close $rfh;
close $parentsock; close $parentsock;
open(STDOUT, '>&', STDERR) or error "cannot open STDOUT: $!"; open(STDOUT, '>&', STDERR) or error "cannot open STDOUT: $!";
setup($options); setup($options);
print $childsock (pack('n', 0) . 'adios'); print $childsock (pack('n', 0) . 'adios');
$childsock->flush(); $childsock->flush();
close $childsock; close $childsock;
if ($options->{maketar} or $options->{makesqfs}) { if ($options->{maketar} or $options->{makesqfs}) {
info "creating tarball..."; info "creating tarball...";
# redirect tar output to the writing end of the pipe so that # redirect tar output to the writing end of the pipe so
# the parent process can capture the output # that the parent process can capture the output
open(STDOUT, '>&', $wfh) or error "cannot open STDOUT: $!"; open(STDOUT, '>&', $wfh) or error "cannot open STDOUT: $!";
# Add ./dev as the first entries of the tar file. # Add ./dev as the first entries of the tar file.
# We cannot add them after calling tar, because there is no way # We cannot add them after calling tar, because there is no
# to prevent tar from writing NULL entries at the end. # way to prevent tar from writing NULL entries at the end.
print $devtar; print $devtar;
# pack everything except ./dev # pack everything except ./dev
0 == system('tar', @taropts, '-C', $options->{root}, '.') 0 == system('tar', @taropts, '-C', $options->{root}, '.')
or error "tar failed: $?"; or error "tar failed: $?";
info "done"; info "done";
} }
exit 0; exit 0;
} },
\@idmap; \@idmap
);
} elsif ( } elsif (
any { $_ eq $options->{mode} } any { $_ eq $options->{mode} }
('root', 'fakechroot', 'proot', 'chrootless') ('root', 'fakechroot', 'proot', 'chrootless')
) { ) {
$pid = fork() // error "fork() failed: $!"; $pid = fork() // error "fork() failed: $!";
if ($pid == 0) { if ($pid == 0) {
$SIG{'INT'} = 'DEFAULT'; local $SIG{'INT'} = 'DEFAULT';
$SIG{'HUP'} = 'DEFAULT'; local $SIG{'HUP'} = 'DEFAULT';
$SIG{'PIPE'} = 'DEFAULT'; local $SIG{'PIPE'} = 'DEFAULT';
$SIG{'TERM'} = 'DEFAULT'; local $SIG{'TERM'} = 'DEFAULT';
# unblock all delayed signals (and possibly handle them) # unblock all delayed signals (and possibly handle them)
POSIX::sigprocmask(SIG_UNBLOCK, $sigset) POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
@ -3503,10 +3555,10 @@ sub main() {
info "main() received signal $got_signal: waiting for $waiting_for..."; info "main() received signal $got_signal: waiting for $waiting_for...";
}; };
$SIG{'INT'} = $ignore; local $SIG{'INT'} = $ignore;
$SIG{'HUP'} = $ignore; local $SIG{'HUP'} = $ignore;
$SIG{'PIPE'} = $ignore; local $SIG{'PIPE'} = $ignore;
$SIG{'TERM'} = $ignore; local $SIG{'TERM'} = $ignore;
# unblock all delayed signals (and possibly handle them) # unblock all delayed signals (and possibly handle them)
POSIX::sigprocmask(SIG_UNBLOCK, $sigset) POSIX::sigprocmask(SIG_UNBLOCK, $sigset)
@ -3880,10 +3932,10 @@ sub main() {
my $cpid = fork() // error "fork() failed: $!"; my $cpid = fork() // error "fork() failed: $!";
if ($cpid == 0) { if ($cpid == 0) {
# child: default signal handlers # child: default signal handlers
$SIG{'INT'} = 'DEFAULT'; local $SIG{'INT'} = 'DEFAULT';
$SIG{'HUP'} = 'DEFAULT'; local $SIG{'HUP'} = 'DEFAULT';
$SIG{'PIPE'} = 'DEFAULT'; local $SIG{'PIPE'} = 'DEFAULT';
$SIG{'TERM'} = 'DEFAULT'; local $SIG{'TERM'} = 'DEFAULT';
# unblock all delayed signals (and possibly handle # unblock all delayed signals (and possibly handle
# them) # them)
@ -3900,7 +3952,7 @@ sub main() {
} }
open(STDIN, '<&', $rfh) open(STDIN, '<&', $rfh)
or error "cannot open file handle for reading: $!"; or error "cannot open file handle for reading: $!";
eval 'Devel::Cover::set_coverage("none")' eval { Devel::Cover::set_coverage("none") }
if $is_covering; if $is_covering;
exec { $argv[0] } @argv exec { $argv[0] } @argv
or or
@ -3943,27 +3995,29 @@ sub main() {
# the unshared namespace, so we remove it here. # the unshared namespace, so we remove it here.
# Since this is still inside the unshared namespace, there is # Since this is still inside the unshared namespace, there is
# no risk of removing anything important. # no risk of removing anything important.
$pid = get_unshare_cmd { $pid = get_unshare_cmd(
# File::Path will produce the error "cannot stat initial sub {
# working directory" if the working directory cannot be # File::Path will produce the error "cannot stat initial
# accessed by the unprivileged unshared user. Thus, we first # working directory" if the working directory cannot be
# navigate to the parent of the root directory. # accessed by the unprivileged unshared user. Thus, we
chdir "$options->{root}/.." # first navigate to the parent of the root directory.
or error "unable to chdir() to parent directory of" chdir "$options->{root}/.."
. " $options->{root}: $!"; or error "unable to chdir() to parent directory of"
remove_tree($options->{root}, { error => \my $err }); . " $options->{root}: $!";
if (@$err) { remove_tree($options->{root}, { error => \my $err });
for my $diag (@$err) { if (@$err) {
my ($file, $message) = %$diag; for my $diag (@$err) {
if ($file eq '') { my ($file, $message) = %$diag;
warning "general error: $message"; if ($file eq '') {
} else { warning "general error: $message";
warning "problem unlinking $file: $message"; } else {
warning "problem unlinking $file: $message";
}
} }
} }
} },
} \@idmap
\@idmap; );
waitpid $pid, 0; waitpid $pid, 0;
$? == 0 or error "remove_tree failed"; $? == 0 or error "remove_tree failed";
} elsif ( } elsif (