File Coverage

blib/lib/Sys/Export/Unix/WriteFS.pm

Criterion	Covered	Total	%
statement	144	219	65.7
branch	51	130	39.2
condition	32	118	27.1
subroutine	21	29	72.4
pod	7	7	100.0
total	255	503	50.7

package Sys::Export::Unix::WriteFS;

# ABSTRACT: An export target that writes files to a directory in the host filesystem
our $VERSION = '0.005'; # VERSION


use v5.26;
use warnings;
use experimental qw( signatures );
use Carp qw( croak carp );
use Scalar::Util qw( blessed );
our @CARP_NOT= qw( Sys::Export::Unix );
use Cwd qw( abs_path );
use Sys::Export qw( :stat_modes :stat_tests isa_hash );
require Sys::Export::Unix;

sub new {
   my $class= shift;
   my %attrs= @_ == 1 && isa_hash $_[0]? %{$_[0]}
      : !(@_ & 1)? @_
      : croak "Expected hashref or even-length list";

   defined $attrs{dst} or croak "Require 'dst' attribute";
   my $dst_abs= abs_path($attrs{dst} =~ s,(?<=[^/])$,/,r)
      or croak "dst directory '$attrs{dst}' does not exist";
   length $dst_abs > 1
      or croak "cowardly refusing to export to '$dst_abs'";
   $attrs{dst_abs}= "$dst_abs/";

   $attrs{tmp} //= do {
      my $tmp= File::Temp->newdir;
      # Make sure can rename() from this $tmp to $dst
      my ($tmp_dev)= stat "$tmp/";
      my ($dst_dev)= stat $attrs{dst};
      $tmp= File::Temp->newdir(DIR => $attrs{dst_abs})
         if $tmp_dev != $dst_dev;
      $tmp;
   };

   my $self= bless \%attrs, $class;

   return $self;
}


sub dst($self)          { $self->{dst} }
sub dst_abs($self)      { $self->{dst_abs} }
sub tmp($self)          { $self->{tmp} }

sub on_collision {
   return shift->_set_on_collision(@_) if @_ > 1;
   shift->{on_collision}
}
my %_valid_on_collision= (
   croak          => 'croak',
   ignore_if_same => 'croak',
   ignore         => 'ignore',
   overwrite      => 'overwrite',
);
sub _set_on_collision($self, $val) {
   $self->{on_collision}= ref $val eq 'CODE'? $val
                        : $_valid_on_collision{$val}
                           // croak("Invalid 'on_collision' value '$val'");
   $self;
}

# a hashref tracking files with link-count higher than 1, so that hardlinks can be preserved.
# the keys are "$dev:$ino"
sub _link_map($self) { $self->{link_map} //= {} }

sub DESTROY($self, @) {
   $self->finish if $self->{_delayed_apply_stat};
}


sub add($self, $file) {
   croak "Path must start with a name, not slash or dot: '$file->{name}'"
      if $file->{name} =~ m{(^|^\.|^\.\.)(/|\z)};
   my $mode= $file->{mode} // croak "attribute 'mode' is required, for '$file->{name}'";
   # Does it already exist?
   my $dst_abs= $self->dst_abs . $file->{name};
   my %old= (name => $file->{name});
   if (@old{qw( dev ino mode nlink uid gid rdev size atime mtime)}= lstat($dst_abs)) {
      my $action= $self->on_collision // 'croak';
      # Nothing to do if user wants collisions ignored
      return !!0 if $action eq 'ignore';
      if (defined(my $difference= $self->_compare_dirent($file, \%old))) {
         # Call user callback, if any
         $action= $action->($dst_abs, $file)
            if ref $action eq 'CODE';
         # validate its return value
         $action= $_valid_on_collision{$action // ''}
               // croak "Unknown on_collision action '$action'";
         return !!0 if $action eq 'ignore';
         croak $difference unless $action eq 'overwrite';
         # overwrite, but directory might not be empty, so handle that later
         unlink $dst_abs unless S_ISDIR($old{mode});
      }
   }
   return S_ISREG($mode)? $self->_add_file($file)
        : S_ISDIR($mode)? $self->_add_dir($file, (defined $old{mode}? \%old : undef))
        : S_ISLNK($mode)? $self->_add_symlink($file)
        : (S_ISBLK($mode) || S_ISCHR($mode))? $self->_add_devnode($file)
        : S_ISFIFO($mode)? $self->_add_fifo($file)
        : S_ISSOCK($mode)? $self->_add_socket($file)
        : croak "Can't export ".(S_ISWHT($mode)? 'whiteout entries' : '(unknown)')
            .': "'.($file->{src_path} // $file->{name}).'"'
}

our %_mode_name= (
   S_IFREG  , 'file',
   S_IFDIR  , 'dir',
   S_IFLNK  , 'symlink',
   S_IFBLK  , 'block device',
   S_IFCHR  , 'char device',
   S_IFIFO  , 'fifo',
   S_IFSOCK , 'socket',
   (S_IFWHT? (
   S_IFWHT  , 'whiteout',
   ):()),
);
sub _mode_name($mode) { $_mode_name{($mode & S_IFMT)} // '(unknown)' }

# Compare two dirents and return error msg if new is not equivalent to old
sub _compare_dirent($self, $file, $old) {
   my $dst_abs= $self->dst_abs . $file->{name};
   return "Attempt to write "._mode_name($file->{mode})." overtop existing "._mode_name($old->{mode})." at $dst_abs"
      if ($file->{mode} & S_IFMT) != ($old->{mode} & S_IFMT);
   return "Attempt to write ownership $file->{uid}:$file->{gid} to $dst_abs which was previously $old->{uid}:$old->{gid}"
      if (defined $file->{uid} && $file->{uid} != $old->{uid}) || (defined $file->{gid} && $file->{gid} != $old->{gid});
   # For symlinks, compare only the content of the link.  Permissions are ignored.
   if (S_ISLNK($file->{mode})) {
      my $targ= readlink $dst_abs;
      return "Attempt to rewrite symlink $dst_abs from $targ to $file->{data}"
         if $targ ne $file->{data};
      return !!0;
   }
   # For everything else, compare permissions
   return "Attempt to write permissions ".($file->{mode} & ~S_IFMT)." overtop existing ".($old->{mode} & ~S_IFMT)." at $dst_abs"
      unless $file->{mode} == $old->{mode};

   if (S_ISREG($file->{mode})) {
      # compare file contents
      return "Attempt to overwrite $dst_abs with different content"
         if (defined $file->{size} && $file->{size} != $old->{size})
            || !_contents_same($file, $dst_abs);
   }
   elsif (S_ISBLK($file->{mode}) || S_ISCHR($file->{mode})) {
      # compare major/minor numbers
      return "Attempt to overwrite $dst_abs with different major/minor value"
         if $file->{rdev} != $old->{rdev};
   }
   undef;
}

# Compare file contents for equality
sub _contents_same($file, $dst_abs) {
   my $dst_data= Sys::Export::map_or_load_file($dst_abs);
   return ${$file->{data}} eq $$dst_data;
}

# compare device nodes for equality
sub _rdev_same($file, $old) {
   # old will always have 'rdev' defined because we ran lstat.
   # file might not if the user specified rdev_major and rdev_minor
   if (defined $file->{rdev}) {
      return $file->{rdev} == $old->{rdev};
   } elsif (defined $file->{rdev_major} && defined $file->{rdev_minor}) {
      my ($maj, $min)= Sys::Export::Unix::_dev_major_minor($old->{rdev});
      return $file->{rdev_major} == $maj && $file->{rdev_minor} == $min;
   } else {
      return !!0; # not defined, so can't be same
   }
}

# Install a file into ->dst
sub _add_file($self, $file) {
   my $dst= $self->dst_abs . $file->{name};
   # See if this is supposed to be a hardlink
   if ($file->{nlink} > 1) {
      if (defined(my $already= $self->_link_map->{"$file->{dev}:$file->{ino}"})) {
         # Yep, make a link of that file instead of copying again
         link($already, $dst)
            or croak "link($already, $dst): $!";
         return !!1;
      }
   }
   # Record all file inodes in case a delayed hardlink is created by the caller
   $self->_link_map->{"$file->{dev}:$file->{ino}"}= $dst
      if defined $file->{dev} && defined $file->{ino};
   # Write data into a temp file on same filesystem, then rename it into place
   #  to ensure we never write a partial file into the destination.
   # But, check if the caller gave us a LazyFileData within our ->tmp directory.
   my $tmp;
   if (blessed $file->{data} && $file->{data}->can('abs_path')
      && substr($file->{data}->abs_path//'', 0, length $self->tmp) eq $self->tmp
   ) {
      $tmp= $file->{data}->abs_path;
   } else {
      $tmp= File::Temp->new(DIR => $self->tmp, UNLINK => 0);
      Sys::Export::Unix::_syswrite_all($tmp, $file->{data});
   }
   # Apply matching permissions and ownership
   $self->_apply_stat("$tmp", $file);
   # Rename the temp file into place
   rename($tmp, $dst) or croak "rename($tmp, $dst): $!";
}

# Install a dir into ->dst, unless it already exists
sub _add_dir($self, $dir, $old) {
   my $dst_abs= $self->dst_abs . $dir->{name};
   # If the directory already exists, just apply the permissions
   mkdir($dst_abs) || croak "mkdir($dst_abs): $!"
      unless $old;
   $self->_apply_stat($dst_abs, $dir);
}

# Install a symlink into ->dst
sub _add_symlink($self, $file) {
   my $dst_abs= $self->dst_abs . $file->{name};
   length $file->{data}
      or croak "Missing symlink contents for $file->{name}";
   symlink($file->{data}, $dst_abs)
      or croak "symlink($file->{data}, $dst_abs): $!";
   $self->_apply_stat($dst_abs, $file);
}

# Install a device node into ->dst
sub _add_devnode($self, $file) {
   if (defined $file->{rdev} && (!defined $file->{rdev_major} || !defined $file->{rdev_minor})) {
      my ($major,$minor)= Sys::Export::Unix::_dev_major_minor($file->{rdev});
      $file->{rdev_major} //= $major;
      $file->{rdev_minor} //= $minor;
   }
   my $dst_abs= $self->dst_abs . $file->{name};
   Sys::Export::Unix::_mknod_or_die($dst_abs, $file->{mode}, $file->{rdev_major}, $file->{rdev_minor});
   $self->_apply_stat($dst_abs, $file);
}

# Install a fifo into ->dst
sub _add_fifo($self, $file) {
   require POSIX;
   my $dst_abs= $self->dst_abs . $file->{name};
   POSIX::mkfifo($dst_abs, $file->{mode})
      or croak "mkfifo($dst_abs): $!";
   $self->_apply_stat($dst_abs, $file);
}

# Bind a socket (thus creating it) in ->dst
sub _add_socket($self, $file) {
   require Socket;
   my $dst_abs= $self->dst_abs . $file->{name};
   socket(my $s, Socket::AF_UNIX(), Socket::SOCK_STREAM(), 0) or die "socket: $!";
   bind($s, Socket::pack_sockaddr_un($dst_abs)) or die "Failed to bind socket at $dst_abs: $!";
   $self->_apply_stat($dst_abs, $file);
}


sub finish($self) {
   my $todo= delete $self->{_delayed_apply_stat};
   # Reverse sort causes child directories to be updated before parents,
   # which is required for updating mtimes.
   $self->_delayed_apply_stat(@$_)
      for sort { $b->[0] cmp $a->[0] } @$todo;
   # free the temp directory if it was located within /dst_abs
   undef $self->{tmp};
}

# Apply permissions and mtime to a path
sub _apply_stat($self, $abs_path, $stat) {
   my ($mode, $uid, $gid, $atime, $mtime)= (lstat $abs_path)[2,4,5,8,9]
      or croak "Failed to stat file just created at '$abs_path': $!";
   my $change_uid= defined $stat->{uid} && $stat->{uid} != $uid;
   my $change_gid= defined $stat->{gid} && $stat->{gid} != $gid;
   if ($change_uid || $change_gid) {
      # only UID 0 can change UID, and only GID 0 or GID in supplemental groups can change GID.
      $uid= -1 unless $change_uid && $> == 0;
      $gid= -1 unless $change_gid && ($) == 0 || grep $stat->{gid}, split / /, $) );
      # Only attempt change if able
      POSIX::lchown($uid, $gid, $abs_path) or croak "lchown($uid, $gid, $abs_path): $!"
         if $uid >= 0 || $gid >= 0;
   }

   my @delayed;

   # Don't change permission bits on symlinks
   if (!S_ISLNK($mode) && ($mode & 0xFFF) != ($stat->{mode} & 0xFFF)) {
      # If changing permissions on a directory to something that removes our ability
      # to write to it, delay this change until the end.
      if (S_ISDIR($mode) && !(($stat->{mode} & 0222) && ($stat->{mode} & 0111))) {
         push @delayed, 'chmod';
      }
      else {
         chmod $stat->{mode}&0xFFF, $abs_path
            or croak sprintf "chmod(0%o, %s): $!", $stat->{mode}&0xFFF, $abs_path;
      }
   }

   if (!S_ISLNK($mode) && (defined $stat->{mtime} || defined $stat->{atime})) {
      if (S_ISDIR($mode)) {
         # No point in applying mtime to a directory now, because it will get
         # changed when sub-entries get written.
         push @delayed, 'utime';
      }
      else {
         utime $stat->{atime}, $stat->{mtime}, $abs_path
            or warn "utime($abs_path): $!";
      }
   }

   push @{$self->{_delayed_apply_stat}}, [ $abs_path, $stat, @delayed ]
      if @delayed;
}
sub _delayed_apply_stat($self, $abs_path, $stat, @delayed) {
   if (grep $_ eq 'chmod', @delayed) {
      chmod $stat->{mode}&0xFFF, $abs_path
         or croak sprintf "chmod(0%o, %s): $!", $stat->{mode}&0xFFF, $abs_path;
   }
   if (grep $_ eq 'utime', @delayed) {
      utime $stat->{atime}, $stat->{mtime}, $abs_path
         or warn "utime($abs_path): $!";
   }
}

# Avoiding dependency on namespace::clean
delete @{Sys::Export::Unix::WriteFS::}{qw(
   carp croak abs_path blessed isa_hash
   S_IFBLK S_IFCHR S_IFDIR S_IFIFO S_IFLNK S_IFMT S_IFREG S_IFSOCK S_IFWHT
   S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISLNK S_ISREG S_ISSOCK S_ISWHT
)};
1;

__END__