view release on metacpan or  search on metacpan

lib/Sys/Export/Unix/WriteFS.pm  view on Meta::CPAN

   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__

=pod

=encoding UTF-8

=head1 NAME