File Coverage

blib/lib/Sys/Export/CPIO.pm

Criterion	Covered	Total	%
statement	64	89	71.9
branch	18	52	34.6
condition	23	50	46.0
subroutine	11	14	78.5
pod	6	6	100.0
total	122	211	57.8

package Sys::Export::CPIO;

# ABSTRACT: Write CPIO archives needed for Linux initrd
our $VERSION = '0.005'; # VERSION

use v5.26;
use warnings;
use experimental qw( signatures );
use Fcntl qw( S_IFDIR S_IFMT );
use Scalar::Util 'blessed';
use Encode ();
use Carp;
our @CARP_NOT= qw( Sys::Export Sys::Export::Unix );
require Sys::Export::Unix; # for _dev_major_minor


sub new($class, $f, @attrs) {
   croak "Expected even-length key/value list after filename" if @attrs & 1;
   my $filename;
   my $fh= blessed $f && $f->can('print')? $f
      : do { $filename= $f; open my $x, '>:raw', $f or die "open($f): $!"; $x };
   my $self= bless {
      fh => $fh,
      seen_inode => {},
      ino => 0,
      virtual_inodes => 1,
      filename => $filename,
      autoclose => defined $filename,
   }, $class;

   while (@attrs) {
      my ($attr, $val)= splice(@attrs, 0, 2);
      $self->$attr($val);
   }

   $self;
}


sub autoclose {
   $_[0]{autoclose}= !!$_[1] if @_ > 1; # cast to boolean
   $_[0]{autoclose}
}

sub filename {
   $_[0]{filename}= $_[1] if @_ > 1;
   $_[0]{filename}
}

sub virtual_inodes {
   $_[0]{virtual_inodes}= !!$_[1] if @_ > 1; # cast to boolean
   $_[0]{virtual_inodes}
}


sub add($self, $fileinfo) {
   my ($dev, $dev_major, $dev_minor, $ino, $mode, $nlink, $uid, $gid, $rdev, $rdev_major, $rdev_minor, $mtime)
      = @{$fileinfo}{qw( dev dev_major dev_minor ino mode nlink uid gid rdev rdev_major rdev_minor mtime )};
   my $name= _fileinfo_get_name_bytes($fileinfo);
   # best-effort to extract major/minor from dev and rdev, unless user specified them
   ($dev_major, $dev_minor)= Sys::Export::Unix::_dev_major_minor($dev)
      if defined $dev and !defined $dev_major || !defined $dev_minor;
   ($rdev_major, $rdev_minor)= Sys::Export::Unix::_dev_major_minor($rdev)
      if defined $rdev and !defined $rdev_major || !defined $rdev_minor;
   defined $mode or croak "require 'mode'";
   defined $name or croak "require 'name'";

   # Die on encoding mistakes
   my ($size, $data_ref)= (0);
   if (defined $fileinfo->{data}) {
      $data_ref= ref $fileinfo->{data}? $fileinfo->{data} : \$fileinfo->{data};
      croak "->{data} must be 8-bit, but encountered wide character at $name"
         if utf8::is_utf8($$data_ref) && !utf8::downgrade($$data_ref, 1);
      $size= length $$data_ref;
   }
   # Handle hard links
   if ($nlink && $nlink > 1 && ($mode & S_IFMT) != S_IFDIR) {
      my $hardlink_key= "$dev_major:$dev_minor:$ino";
      if ($self->virtual_inodes) {
         # the previous virtual inode is stored in the seen_inode hash
         if ($ino= $self->{seen_inode}{$hardlink_key}) {
            $size= 0;
         } else {
            $ino= $self->{seen_inode}{$hardlink_key}= ++$self->{ino};
         }
         ($dev_major, $dev_minor)= (0,0);
      }
      else {
         $size= 0 if $self->{seen_inode}{$hardlink_key}++;
      }
   }
   elsif ($self->virtual_inodes) {
      ($dev_major, $dev_minor, $ino)= (0,0);
   }
   $ino //= ++$self->{ino};

   my $header= sprintf "070701%08X%08X%08X%08X%08X%08X%08X%08X%08X%08X%08X%08X%08X%s\0%s",
      $ino, $mode, $uid//0, $gid//0, $nlink//1, $mtime//0, $size,
      $dev_major//0, $dev_minor//0, $rdev_major//0, $rdev_minor//0,
      1+length $name, 0, $name,
      "\0"x((4 - ((13*8+6+length($name)+1) & 3)) & 3); # pad to multiple of 4
   die "BUG" if length $header & 3;

   $self->{fh}->print($header) || die "write: $!";
   # This is written in multiple parts like this because $fileinfo->{data} might be a memory-
   #  mapped file, and optimal to pass that directly back to fprint without a perl-side
   #  concatenation.
   $self->{fh}->print($$data_ref) || die "write: $!"
      if $size;
   $self->{fh}->print("\0"x(4-($size & 3))) || die "write: $!"
      if $size & 3; # pad to multiple of 4
   $self;
}

sub _fileinfo_get_name_bytes($f) {
   if (defined (my $name= $f->{name})) {
      !utf8::is_utf8($name) or utf8::downgrade($name, 1)
         or croak "->{name} must be encoded as bytes, but encountered wide character at $name";
      return $name;
   } elsif (defined $f->{uname}) {
      return Encode::encode('UTF-8', $f->{uname}, Encode::FB_CROAK|Encode::LEAVE_SRC);
   } else {
      croak "Must specify either 'name' or 'uname'";
   }
}


sub finish($self) {
   $self->add({ mode => 0, ino => 0, name => 'TRAILER!!!' });
   $self->{fh}->flush;
   $self->{fh}->close if $self->autoclose;
   $self;
}

# Avoiding dependency on namespace::clean
delete @{Sys::Export::CPIO::}{qw( S_IFDIR S_IFMT blessed carp croak confess )};
1;

__END__