File Coverage

blib/lib/Test/Archive/Libarchive.pm

Criterion	Covered	Total	%
statement	92	104	88.4
branch	20	32	62.5
condition	5	8	62.5
subroutine	14	14	100.0
pod	1	1	100.0
total	132	159	83.0

package Test::Archive::Libarchive;

use strict;
use warnings;
use 5.020;
use Test2::Tools::Basic qw( diag );
use Test2::Tools::Compare qw( is object call T );
use Test2::API qw( context release );
use Ref::Util qw( is_blessed_ref );
use experimental qw( signatures );
use parent qw( Exporter );

# ABSTRACT: Testing tools for Archive::Libarchive
our $VERSION = '0.01'; # VERSION


our @EXPORT = qw( la_ok la_eof la_warn la_failed la_fatal la_read_data_ok );

our %code = (
  eof    =>   1,
  ok     =>   0,
  retry  => -10,
  warn   => -20,
  failed => -25,
  fatal  => -30,
);

sub _ok
{
  my($code, $archive, $method, $arguments, $test_name) = @_;

  $test_name //= do {
    my $name = "\$archive->$method";
    if(@$arguments)
    {
      my $first = 1;
      $name .= '(';
      foreach my $arg (@$arguments)
      {
        $name .= ", " unless $first;
        $first = 0;

        my $ref = ref $arg;
        if($ref eq '')
        {
          if(length $arg > 34)
          {
            $name .= "'@{[ substr($arg, 0, 30) =~ s/\n/\\n/rg ]}...'";
          }
          else
          {
            $name .= "'@{[ $arg =~ s/\n/\\n/rg ]}'";
          }
        }
        elsif($ref eq 'HASH')
        {
          $name .= "{...}";
        }
        elsif($ref eq 'ARRAY')
        {
          $name .= "[...]";
        }
        elsif($ref eq 'CODE')
        {
          $name .= "sub {...}";
        }
      }
      $name .= ')';
    }
    $name .= " == ARCHIVE_@{[ uc $code ]}";
    $name;
  };

  my $ret = is(
    $archive,
    object {
      call([ isa => 'Archive::Libarchive::Archive' ] => T());
      if(@$arguments)
      {
        call([ $method => @$arguments ] => $code{$code});
      }
      else
      {
        call($method => $code{$code});
      }
    },
    $test_name,
  );

  unless($ret)
  {
    if(defined $archive)
    {
      if($archive->can('errno'))
      {
        diag("error: @{[ $archive->errno ]}");
      }
      if($archive->can('error_string'))
      {
        diag("error: @{[ $archive->error_string ]}");
      }
    }
    else
    {
      diag("archive is not defined");
    }
  }

  return $ret;
}


foreach my $code (qw( ok eof retry warn failed fatal )) {

  my $sub = sub ($archive, $method, $arguments=[], $test_name=undef)
  {
    my $ctx = context();
    my $ret = _ok($code, $archive, $method, $arguments, $test_name=undef);
    $ctx->release;
    return $ret;
  };

  no strict 'refs';
  *{"la_$code"} = $sub;
}


sub la_read_data_ok ($r, $test_name=undef)
{
  my $ctx = context();

  $test_name ||= "\$archive->read_data(\\\$buffer) >= 0;  # multiple calls";

  my $content = '';

  unless(is_blessed_ref $r && $r->isa("Archive::Libarchive::ArchiveRead"))
  {
    $ctx->fail_and_release($test_name, "Object is not an instance of Archive::Libarchive::ArchiveRead");
    return $content;
  }

  unless($r->can('read_data'))
  {
    $ctx->fail_and_release($test_name, "Object does not implement read_data");
    return $content;
  }

  my $count = 0;

  while(1)
  {
    my $buffer;
    $count++;
    my $size = $r->read_data(\$buffer);
    if($size > 0)
    {
      $content .= $buffer;
    }
    elsif($size == 0)
    {
      last;
    }
    else
    {
      my %rcode = map { $code{$_} => "ARCHIVE_" . uc($_) } keys %code;
      $ctx->fail_and_release($test_name, "Call read_data # $count returned $rcode{$size}");
      return $content;
    }
  }

  $ctx->pass_and_release($test_name);
  return $content;
}

1;

__END__