File Coverage

blib/lib/Alien/Build/Plugin/Extract/ArchiveTar.pm

Criterion	Covered	Total	%
statement	52	57	91.2
branch	10	14	71.4
condition	4	9	44.4
subroutine	11	12	91.6
pod	3	3	100.0
total	80	95	84.2

package Alien::Build::Plugin::Extract::ArchiveTar;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::chdir;
use File::Temp ();
use Path::Tiny ();

# ABSTRACT: Plugin to extract a tarball using Archive::Tar
our $VERSION = '2.47'; # VERSION


has '+format' => 'tar';


sub handles
{
  my(undef, $ext) = @_;

  return 1 if $ext =~ /^(tar|tar.gz|tar.bz2|tbz|taz)$/;

  return 0;
}


sub available
{
  my(undef, $ext) = @_;

  if($ext eq 'tar.gz')
  {
    return !! eval { require Archive::Tar; Archive::Tar->has_zlib_support };
  }
  elsif($ext eq 'tar.bz2')
  {
    return !! eval { require Archive::Tar; Archive::Tar->has_bzip2_support && __PACKAGE__->_can_bz2 };
  }
  else
  {
    return $ext eq 'tar';
  }
}

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'Archive::Tar' => 0);
  if($self->format eq 'tar.gz' || $self->format eq 'tgz')
  {
    $meta->add_requires('share' => 'IO::Zlib' => 0);
  }
  elsif($self->format eq 'tar.bz2' || $self->format eq 'tbz')
  {
    $meta->add_requires('share' => 'IO::Uncompress::Bunzip2' => 0);
    $meta->add_requires('share' => 'IO::Compress::Bzip2' => 0);
  }

  $meta->register_hook(
    extract => sub {
      my($build, $src) = @_;
      my $tar = Archive::Tar->new;
      $tar->read($src);
      $tar->extract;
    }
  );
}

sub _can_bz2
{
  # even when Archive::Tar reports that it supports bz2, I can sometimes get this error:
  # 'Cannot read enough bytes from the tarfile', so lets just probe for actual support!
  my $dir = Path::Tiny->new(File::Temp::tempdir( CLEANUP => 1 ));
  eval {
    local $CWD = $dir;
    my $tarball = unpack "u", q{M0EIH.3%!62936=+(]$0``$A[D-$0`8!``7^``!!AI)Y`!```""``=!JGIH-(MT#0]0/2!**---&F@;4#0&:D;X?(6@JH(2<%'N$%3VHC-9E>S/N@"6&I*1@GNJNHCC2>$I5(<0BKR.=XBZ""HVZ;T,CV\LJ!K&*?9`#\7
    Path::Tiny->new('xx.tar.bz2')->spew_raw($tarball);
    require Archive::Tar;
    my $tar = Archive::Tar->new;
    $tar->read('xx.tar.bz2');
    $tar->extract;
    my $content = Path::Tiny->new('xx.txt')->slurp;
    die unless $content && $content eq "xx\n";
  };
  my $error = $@;
  $dir->remove_tree;
  !$error;
}

1;

__END__