File Coverage

blib/lib/Sys/Export/Linux.pm

Criterion	Covered	Total	%
statement	67	162	41.3
branch	13	74	17.5
condition	3	29	10.3
subroutine	12	16	75.0
pod	5	5	100.0
total	100	286	34.9

package Sys::Export::Linux;

# ABSTRACT: Export subsets of a Linux system
our $VERSION = '0.005_002'; # TRIAL VERSION


use v5.26;
use warnings;
use experimental qw( signatures );
use parent 'Sys::Export::Unix';
use Cwd 'abs_path';
use Carp;
use Sys::Export 'filedata';
use Sys::Export::LogAny '$log';

sub _build__trace_deps {
   my $self= shift;
   if ($self->_can_run_in_src) {
      # Seems Solaris has an 'strace' but it isn't compatible enough to pass tests.
      $^O eq 'linux' or croak "Only Linux strace is supported";
      # Are we going to attempt chrooting?
      if ($self->src_abs ne '/') {
         $self->{cmd_path_chroot} //= do {
            chomp(my $chroot= `which chroot`);
            -x $chroot or croak "chroot command not available or not executable";
            $self->{_log_trace}->("chroot binary at $chroot") if $self->{_log_trace};
            $chroot;
         };
      }
      $self->{cmd_path_strace} //= do {
         chomp(my $strace= `which strace`);
         -x $strace or croak "strace command not available or not executable";
         $self->{_log_trace}->("strace binary at $strace") if $self->{_log_trace};
         $strace;
      };
      return $self->can('_trace_deps_linux_strace');
   }
   $self->next::method(@_);
}

sub _trace_deps_linux_strace($self, @argv) {
   # Are we going to attempt chrooting?
   unshift @argv, $self->{cmd_path_chroot}, $self->src_abs
      unless $self->src_abs eq '/';
   # Tell strace to write to a pipe, while redirecting command output to /dev/null
   open my $devnull, '+<', '/dev/null' or croak "open(/dev/null): $!";
   pipe(my $r, my $w) // croak "pipe: $!";
   pipe(my $err_r, my $err_w) // croak "pipe: $!";
   my $pid= fork // croak "fork: $!";
   if (!$pid) {
      close $r;
      close $err_r;
      eval {
         chdir $self->src_abs or die "chdir: $!";
         POSIX::dup2(fileno $devnull, 0) or die "dup2(->0): $!";
         POSIX::dup2(fileno $devnull, 1) or die "dup2(->1): $!";
         POSIX::dup2(fileno $devnull, 2) or die "dup2(->2): $!";
         POSIX::dup2(fileno $w, 3) or die "dup2(->3): $!";
         $^F= 3;
         unshift @argv, $self->{cmd_path_strace}, -o => "/proc/self/fd/3", -e => 'trace=open,openat';
         exec @argv
            or die "exec(@argv): $!";
      };
      $err_w->print($@);
      $err_w->close;
      POSIX::_exit(2); # forcibly exit rather than bubble up the stack
   }
   else {
      close $w;
      close $err_w;
      my %deps;
      my $err= do { local $/; <$err_r> };
      if (length $err) {
         waitpid($pid, 0);
         die $err;
      }
      $self->{_log_trace}->("Reading strace output") if $self->{_log_trace};
      while (<$r>) {
         $self->{_log_trace}->($_) if $self->{_log_trace};
         $deps{$1}= 1 if /^open(?:at)?\(.*?"(.*?)",.*?= [0-9]/;
      }
      $self->{_log_trace}->("Done reading strace") if $self->{_log_trace};
      waitpid($pid,0);
      my $wstat= $?;
      $self->{_log_trace}->("Command exited with $wstat") if $self->{_log_trace};
      croak "straced command failed: wstat = $wstat"
         if $wstat;
      return \%deps;
   }
}


sub parse_ld_so_conf($self, $conf_path= 'etc/ld.so.conf') {
   my $data= filedata($self->src_abs . $conf_path);
   my @libs;
   for (split /\n/, $$data) {
      chomp;
      next if /^\s*(#|\z)/;
      if (/^\s*include (\S+)/) {
         my $pattern= $1;
         # relative paths are relative to the config file's parent directory
         my $prefix= $pattern =~ s{^/}{}? '' : ($conf_path =~ s{[^/]+\z}{}r);
         push @libs, $self->parse_ld_so_conf($_)
            for $self->src_glob($prefix.$pattern);
      }
      elsif (m{^/}) {
         push @libs, substr($_, 1);
      }
      else {
         $log->warn("parse_ld_so_conf: unknown syntax at '$_'");
      }
   }
   return @libs;
}

sub _build_src_lib_path($self) {
   my $paths= $self->next::method();
   # ld.so.conf may or may not be used on this host
   if (defined $self->_src_abs_path('etc/ld.so.conf')) {
      eval { $paths= $self->_distinct_abs_directories(1, @$paths, $self->parse_ld_so_conf) }
         or $self->log->warn("Failed to parse ld.so.conf: $@");
   }
   return $paths;
}


sub parse_nsswitch_conf($self, $conf_path= 'etc/nsswitch.conf') {
   my $data= filedata($self->src_abs . $conf_path);
   my @db_conf;
   for (split /\n/, $$data) {
      chomp;
      next if /^\s*(#|\z)/;
      if (m{^\s*([^\s:]+)\s*:\s*(\S.+)}) {
         push @db_conf, $1 => [ split /\s+/, $2 ];
      }
      else {
         $log->warn("parse_nsswitch_conf: unknown syntax at '$_'");
      }
   }
   return @db_conf;
}


sub add_nsswitch_libs($self, @module_names) {
   if (!@module_names) {
      my %seen;
      for ($self->parse_nsswitch_conf) {
         next unless ref eq 'ARRAY';
         ++$seen{$_} for @$_;
      }
      @module_names= sort keys %seen;
   }
   my $abs= $self->src_abs;
   my @libpath= $self->src_lib_path_list;
   ns_module: for (@module_names) {
      my $pattern= 'libnss_'.$_.'.*';
      for my $libdir (@libpath) {
         $log->tracef("Look for %s in %s", $pattern, $libdir);
         if (my @match= glob $abs . $pattern) {
            $self->add(map substr($_, length $abs), @match);
            next ns_module;
         }
      }
      $log->warn("glibc nss module not found: $_");
   }
}


sub add_passwd($self, %options) {
   # If the dst_userdb hasn't been created, create it by filtering the src_userdb by which
   # group and user ids have been seen during the export.
   my $db= $self->dst_userdb // Sys::Export::Unix::UserDB->new(
      auto_import => ($self->{src_userdb} //= $self->_build_src_userdb),
   );
   $db->group($_) for keys $self->dst_gid_used->%*;
   $db->user($_) for keys $self->dst_uid_used->%*;
   $db->save(\my %contents);
   my $etc_path= $options{etc_path} // 'etc';
   $self->add([ dir755  => "$etc_path", { uid => 0, gid => 0 }]);
   $self->add([ file644 => "$etc_path/passwd", $contents{passwd}, { uid => 0, gid => 0 }]);
   $self->add([ file600 => "$etc_path/shadow", $contents{shadow}, { uid => 0, gid => 0 }]);
   $self->add([ file644 => "$etc_path/group",  $contents{group},  { uid => 0, gid => 0 }]);
   $self;
}


sub add_localtime($self, $tz_name) {
   if (exists $self->{dst_path_set}{"usr/share/zoneinfo/$tz_name"}
      || ($self->_dst->can('dst_abs') && -f $self->_dst->dst_abs . $tz_name)
   ) {
      # zoneinfo is exported, and includes this timezone, so symlink to it
      $self->add([ sym => "etc/localtime" => "../usr/share/zoneinfo/$tz_name" ]);
   }
   elsif (defined (my $src_path= $self->_src_abs_path("usr/share/zoneinfo/$tz_name"))) {
      $self->add([ file644 => 'etc/localtime', { data_path => $self->src_abs . $src_path } ]);
   }
   elsif (defined (my $path= abs_path("/usr/share/zoneinfo/$tz_name"))) {
      $self->add([ file644 => 'etc/localtime', { data_path => $path } ]);
   }
   else {
      croak "Can't find 'usr/share/zoneinfo/$tz_name' in destination, source, or host filesystem";
   }
}

# Avoiding dependency on namespace::clean
delete @{Sys::Export::Linux::}{qw( croak carp confess abs_path filedata )};
1;

__END__