File Coverage

blib/lib/Sys/Export.pm

Criterion	Covered	Total	%
statement	138	170	81.1
branch	62	112	55.3
condition	19	43	44.1
subroutine	32	40	80.0
pod	26	28	92.8
total	277	393	70.4

package Sys::Export;

our $VERSION = '0.006'; # VERSION
# ABSTRACT: Export a subset of an OS file tree, for chroot/initrd

use v5.26;
use warnings;
use experimental qw( signatures );
use Carp;
use Scalar::Util qw( blessed looks_like_number );
use Sys::Export::LogAny '$log';
use Exporter ();
use Fcntl ':mode';
BEGIN {
   # Fcntl happily exports macros that don't exist, then fails at runtime.
   # Replace non-existent test macros with 'false', and nonexistent modes with 0.
   # But, on MSWin32, the constant for S_IFLNK is 0x4000 and just isn't defined in Fcntl
   # because the headers don't define it.
   for (qw( S_ISREG S_ISDIR S_ISLNK S_ISBLK S_ISCHR S_ISFIFO S_ISSOCK S_ISWHT
            S_IFREG S_IFDIR S_IFLNK S_IFBLK S_IFCHR S_IFIFO  S_IFSOCK S_IFWHT S_IFMT )
   ) {
      next if eval { __PACKAGE__->can($_)->($_ =~ /_IS/? (0) : ()); 1 };
      delete ${Sys::Export::}{$_};
      if ($^O eq 'MSWin32' && $_ eq 'S_IFLNK') {
         eval 'sub Sys::Export::S_IFLNK { 0x6000 } 1' or die "S_IFLNK $@";
      } elsif ($^O eq 'MSWin32' && $_ eq 'S_ISLNK') {
         eval 'sub Sys::Export::S_ISLNK { S_IFMT($_[0]) == 0x6000 } 1' or die "S_ISLNK $@";
      } else {
         eval "sub Sys::Export::$_ { 0 } 1" or die "$@";
      }
   }
}
our @EXPORT_OK= qw(
   isa_exporter isa_export_dst isa_userdb isa_user isa_group exporter isa_hash isa_array isa_int
   isa_handle isa_pow2 isa_data_ref round_up_to_pow2 round_up_to_multiple map_or_load_file filedata
   add skip find which finish rewrite_path rewrite_user rewrite_group expand_stat_shorthand
   write_file_extent _pack _unpack
   S_ISREG S_ISDIR S_ISLNK S_ISBLK S_ISCHR S_ISFIFO S_ISSOCK S_ISWHT
   S_IFREG S_IFDIR S_IFLNK S_IFBLK S_IFCHR S_IFIFO  S_IFSOCK S_IFWHT S_IFMT
);
our %EXPORT_TAGS= (
   basic_methods => [qw( exporter add skip find which finish rewrite_path rewrite_user rewrite_group filedata )],
   isa => [qw( isa_exporter isa_export_dst isa_userdb isa_user isa_group isa_hash isa_array isa_handle isa_int isa_pow2 isa_data_ref )],
   stat_modes => [qw( S_IFREG S_IFDIR S_IFLNK S_IFBLK S_IFCHR S_IFIFO  S_IFSOCK S_IFWHT S_IFMT )],
   stat_tests => [qw( S_ISREG S_ISDIR S_ISLNK S_ISBLK S_ISCHR S_ISFIFO S_ISSOCK S_ISWHT )],
);
my ($is_module_name, $require_module);

# optional dependency on Module::Runtime.  This way if there's any bug in my cheap
# substitute, the fix is to just install the official module.
if (eval { require Module::Runtime; }) {
   $is_module_name= \&Module::Runtime::is_module_name;
   $require_module= \&Module::Runtime::require_module;
} else {
   $is_module_name= sub { $_[0] =~ /^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*\z/ };
   $require_module= sub { require( ($_[0] =~ s{::}{/}gr).'.pm' ) };
}


sub import {
   my $class= $_[0];
   my $caller= caller;
   my %ctor_opts;
   for (my $i= 1; $i < $#_; ++$i) {
      if (ref $_[$i] eq 'HASH') {
         %ctor_opts= ( %ctor_opts, %{ splice(@_, $i--, 1) } );
      }
      elsif ($_[$i] =~ /^-(type|src|dst|tmp|src_userdb|dst_userdb|rewrite_path|rewrite_user|rewrite_group)\z/) {
         $ctor_opts{$1}= (splice @_, $i--, 2)[1];
      }
   }
   if (keys %ctor_opts) {
      init_global_exporter(%ctor_opts);
      # caller requested the global exporter instance, so also include the standard methods
      # unless it looks like they were more selective about what to import.
      push @_, 'exporter', ':basic_methods'
         unless grep /^(add|:.*methods)\z/, @_;
   }
   goto \&Exporter::import;
}

our $exporter;
sub exporter { $exporter }

our %osname_to_class= (
   linux => 'Linux',
);

sub init_global_exporter(%config) {
   my $type= delete $config{type} // $^O;
   # remap known OS names
   my $class= $osname_to_class{$type} // $type;
   # prefix bare names with namespace
   $class= "Sys::Export::$class" unless $class =~ /::/;
   $is_module_name->($class) or croak "Invalid module name '$class'";
   # if it fails, die with 'croak'
   eval { $require_module->($class) } or croak "$@";
   # now construct one
   $exporter= $class->new(%config);
}


sub add           { $exporter->add(@_) }
sub skip          { $exporter->skip(@_) }
sub find          { $exporter->src_find(@_) }
sub which :prototype($) { $exporter->src_which(@_) }
sub finish        { $exporter->finish(@_) }
sub rewrite_path  { $exporter->rewrite_path(@_) }
sub rewrite_user  { $exporter->rewrite_user(@_) }
sub rewrite_group { $exporter->rewrite_group(@_) }


sub isa_hash       :prototype($) { ref $_[0] eq 'HASH' }
sub isa_array      :prototype($) { ref $_[0] eq 'ARRAY' }
sub isa_handle     :prototype($) { ref $_[0] eq 'GLOB' || (ref $_[0] && (ref $_[0])->isa('IO::Handle')) }
sub isa_int        :prototype($) { looks_like_number($_[0]) && int($_[0]) == $_[0] }
sub isa_exporter   :prototype($) { blessed($_[0]) && $_[0]->isa('Sys::Export::Exporter') }
sub isa_export_dst :prototype($) { blessed($_[0]) && $_[0]->can('add') && $_[0]->can('finish') }
sub isa_userdb     :prototype($) { blessed($_[0]) && $_[0]->can('user') && $_[0]->can('group') }
sub isa_user       :prototype($) { blessed($_[0]) && $_[0]->isa('Sys::Export::Unix::UserDB::User') }
sub isa_group      :prototype($) { blessed($_[0]) && $_[0]->isa('Sys::Export::Unix::UserDB::Group') }
sub isa_pow2       :prototype($) { !($_[0] & ($_[0]-1)) }
sub isa_data_ref   :prototype($) { ref $_[0] eq 'SCALAR' || blessed($_[0]) && $_[0]->can('as_scalarref') }


sub _parse_major_minor_data($attrs, $data) {
   @{$attrs}{'rdev_major','rdev_minor'}= isa_array $data? @$data : split(/[,:]/, $data);
}
our %_mode_alias= (
   file => [ S_IFREG,  sub { 0666 & ~umask } ],
   dir  => [ S_IFDIR,  sub { 0777 & ~umask } ],
   sym  => [ S_IFLNK,  sub { 0777 } ],
   blk  => [ S_IFBLK,  sub { 0666 & ~umask }, \&_parse_major_minor_data, ],
   chr  => [ S_IFCHR,  sub { 0666 & ~umask }, \&_parse_major_minor_data, ],
   fifo => [ S_IFIFO,  sub { 0666 & ~umask } ],
   sock => [ S_IFSOCK, sub { 0666 & ~umask } ],
);
our @_mode_by_int;
$_mode_by_int[$_->[0]]= $_ for values %_mode_alias;
$_mode_by_int[0]= undef; # don't map 0 to any mode

sub expand_stat_shorthand {
   @_= @{$_[0]} if @_ == 1 && isa_array $_[0];
   my %attrs= @_ > 2 && isa_hash $_[-1]? %{ pop @_ } : ();
   my ($mode, $name, $data)= @_;
   my $mode_desc;
   if (isa_int $mode) {
      $mode_desc= $_mode_by_int[$mode & S_IFMT]
         or carp sprintf("Numeric mode %x doesn't match any known node types", $mode);
   }
   else {
      $mode =~ /^([a-z]+)([0-7]+)?\z/
         or croak "Invalid mode '$mode': expected number, or prefix file/dir/sym/blk/chr/fifo/sock followed by octal permissions";
      $mode_desc= $_mode_alias{$1}
         or croak "Unknown mode alias '$1'";
      $mode= $mode_desc->[0] | (defined $2? oct($2) : $mode_desc->[1]->());
   }
   $attrs{mode}= $mode;
   length $name or croak "Name must be nonzero length";
   $attrs{name}= $name;
   if (defined $data) {
      if ($mode_desc && $mode_desc->[2]) {
         $mode_desc->[2]->(\%attrs, $data);
      } else {
         $attrs{data}= $data;
      }
   }
   return %attrs;
}


sub round_up_to_pow2($n) {
   croak "Not defined for negative numbers" unless $n > 0;
   return 1 if $n <= 1;
   --$n;
   $n |= $n >> 1;
   $n |= $n >> 2;
   $n |= $n >> 4;
   $n |= $n >> 8;
   $n |= $n >> 16;
   $n |= $n >> 32;
   return $n+1;
}

sub round_up_to_multiple($n, $pow2) {
   croak "Not defined for negative numbers" unless $n > 0;
   my $mask= $pow2-1;
   return ($n + $mask) & ~$mask;
}


if (eval { require File::Map; }) {
   eval q{
      sub map_or_load_file($filename, $offset=0, $length=undef) {
         my $buf;
         defined $length? File::Map::map_file($buf, $filename, "<", $offset, $length)
            : File::Map::map_file($buf, $filename, "<", $offset, $length);
         return \$buf;
      }
      1;
   } or die "$@";
} else {
   *map_or_load_file= *_load_file;
}

sub _load_file($filename, $offset= 0, $length= undef) {
   open my $fh, "<:raw", $filename
      or die "open($filename): $!";
   my $size= -s $fh;
   croak "Offset beyond end of file ($filename, $offset > $size)" if $offset > $size;
   $length //= $size - $offset;
   my $buf= '';
   if ($length) {
      if ($offset > 0) {
         sysseek($fh, $offset, 0) == $offset
            or croak "sysseek($filename, $offset): $!";
      }
      sysread($fh, $buf, $length) == $size
         or die "sysread($filename, $size): $!";
   }
   \$buf;
}


sub filedata {
   state $loaded= require Sys::Export::LazyFileData;
   Sys::Export::LazyFileData->new(@_);
}


sub write_file_extent($fh, $addr, $size, $data_ref, $ofs=0, $descrip=undef) {
   $log->tracef("write %s at 0x%X-0x%X from buf size 0x%X%s",
      $descrip//'blocks', $addr, $addr+$size, length($$data_ref), $ofs? sprintf(" ofs 0x%X", $ofs) : ''
      ) if $log->is_trace;
   return unless $size > 0;
   if (defined $addr) {
      my $reached= sysseek($fh, $addr, 0) // croak "sysseek($addr): $!";
      $reached == $addr or croak "sysseek($addr) arrived at $reached instead of $addr";
   }
   $ofs //= 0;
   my $avail= $data_ref? (length($$data_ref) - $ofs) : 0;
   my $second;
   # always write full size, padding with zeroes
   if ($avail < $size) {
      # If the scalar is particularly large, do two writes instead of reallocating the buffer.
      if ($avail > 0x100000) {
         my $first_write= $avail - ($avail & 0xFFF);
         $second= pack 'a'.($size-$first_write), substr($$data_ref, $first_write);
         $size= $first_write;
      } else {
         my $data= pack 'a'.$size, ($avail > 0? substr($$data_ref, $ofs) : '');
         $data_ref= \$data;
         $ofs= 0;
      }
   }
   my $wrote= syswrite($fh, $$data_ref, $size, $ofs);
   croak "syswrite: $!" if !defined $wrote;
   croak "Unexpected short write ($wrote != $size)" if $wrote != $size;
   if (length $second) {
      $wrote= syswrite($fh, $second);
      croak "syswrite: $!" if !defined $wrote;
      croak "Unexpected short write ($wrote != $size)" if $wrote != length($second);
   }
   return 1;
}

if (eval { pack('Q<', 1) }) {
   *_pack= \*CORE::pack;
   *_unpack= \*CORE::unpack;
} else {
   eval <<'END';
   # On perl without 64-bit support, replace all 'Q' with 32-bit operations
   # This does not handle full pack syntax, just what is used in this module collection.
   sub _pack {
      my $fmt= shift;
      my $new_fmt= '';
      my @new_args;
      require Math::BigInt;
      my $mask32= Math::BigInt->new('4294967295');
      for (split / +/, $fmt) {
         if ($_ eq 'Q>') {
            # Convert a 64-bit integer into two 32-bit big-endian arguments
            $new_fmt .= 'NN';
            my $qw= Math::BigInt->new(shift);
            push @new_args, ($qw >> 32)->numify(), ($qw & $mask32)->numify();
         } elsif ($_ eq 'Q<') {
            # Convert 64-bit integer into two 32-bit little-endian arguments
            $new_fmt .= 'VV';
            my $qw= Math::BigInt->new(shift);
            push @new_args, ($qw & $mask32)->numify(), ($qw >> 32)->numify();
         } else {
            $new_fmt .= $_;
            push @new_args, shift;
         }
      }
      return pack $new_fmt, @new_args;
   }
   # This does not handle full unpack syntax, just what is used in this module collection.
   sub _unpack {
      my $fmt= shift;
      my $new_fmt= '';
      my @replacements;
      require Math::BigInt;
      my @fields= split / +/, $fmt;
      for (reverse 0 .. $#fields) {
         if ($fields[$_] eq 'Q>') {
            $new_fmt .= 'a8';
            push @replacements, [ $_, sub {
               my ($h,$l)= unpack('NN', $_[0]);
               (Math::BigInt->new($h) << 32) | $l
            }];
         } elsif ($fields[$_] eq 'Q<') {
            $new_fmt .= 'a8';
            push @replacements, [ $_, sub {
               my ($l, $h)= unpack('VV', $_[0]);
               (Math::BigInt->new($h) << 32) | $l
            }];
         }
      }
      my @vals= unpack $new_fmt;
      for (@replacements) {
         $vals[$_->[0]]= $_->[1]->($vals[$_->[0]]);
      }
      return @vals;
   }
END
}

1;

__END__