File Coverage

blib/lib/Archive/Ar/Libarchive.pm

Criterion	Covered	Total	%
statement	119	131	90.8
branch	31	46	67.3
condition	13	20	65.0
subroutine	26	28	92.8
pod	11	14	78.5
total	200	239	83.6

package Archive::Ar::Libarchive;

use strict;
use warnings;
use base qw( Exporter );
use constant COMMON => 1;
use constant BSD    => 2;
use constant GNU    => 3;
use Carp qw( carp longmess );
use File::Basename ();

# ABSTRACT: Interface for manipulating ar archives with libarchive
our $VERSION = '2.08'; # VERSION

require XSLoader;
XSLoader::load('Archive::Ar::Libarchive', $VERSION);

our @EXPORT_OK = qw( COMMON BSD GNU );


sub new
{
  my($class, $filename_or_handle, $debug) = @_;
  my $self = _new();
  $self->DEBUG if $debug;

  if($filename_or_handle)
  {
    unless($self->read($filename_or_handle))
    {
      return $self->_error("new() failed on filename for filehandle read");
    }
  }

  $self;
}


sub read
{
  my($self, $filename_or_handle) = @_;

  my $ret = 0;

  if(ref $filename_or_handle)
  {
    return $self->_error("Not a filehandle") unless eval{*$filename_or_handle{IO}} or $filename_or_handle->isa('IO::Handle');
    my $buffer;
    $ret = $self->_read_from_callback(sub {
      my $br = read $filename_or_handle, $buffer, 1024;
      ((defined $br ? 0 : -30), \$buffer);
    });
    close $filename_or_handle;
  }
  else
  {
    $ret = $self->_read_from_filename($filename_or_handle);
  }

  $ret || undef;
}


sub read_memory
{
  my($self, $data) = @_;

  open my $fh, '<', \$data;
  binmode $fh;
  my $ret = $self->read($fh);

  $ret;
}


sub chmod
{
  my($self, $filename, $mode) = @_;
  $self->_chmod($filename, $mode + 0 eq $mode ? $mode : oct($mode));
}


sub chown
{
  my($self, $filename, $uid, $gid) = @_;
  $self->_chown($filename, $uid, $gid);
}


sub remove
{
  my $self = shift;
  my $count = 0;
  foreach my $pathname (@{ ref $_[0] ? $_[0] : \@_ })
  {
    $count += $self->_remove($pathname);
  }
  $count;
}


sub list_files
{
  my $list = shift->_list_files;
  wantarray ? @$list : $list; ## no critic (Freenode::Wantarray)
}


sub add_files
{
  my $self = shift;
  my $count = 0;
  foreach my $filename (@{ ref $_[0] ? $_[0] : \@_ })
  {
    unless(-r $filename)
    {
      $self->_error("No such file: $filename");
      next;
    }
    my @props = stat($filename);
    unless(@props)
    {
      $self->_error("Could not stat $filename.");
      next;
    }

    open(my $fh, '<', $filename) || do {
      $self->_error("Unable to open $filename $!");
      next;
    };
    binmode $fh;
    # TODO: we don't check for error on the actual
    # read operation (but then nethier does
    # Archive::Ar).
    my $data = do { local $/; <$fh> };
    close $fh;

    $self->add_data(File::Basename::basename($filename), $data, {
      date => $props[9],
      uid  => $props[4],
      gid  => $props[5],
      mode => $props[2],
      size => length $data,
    });
    $count++;
  }

  return unless $count;
  $count;
}


sub add_data
{
  my($self, $filename, $data, $filedata) = @_;
  $filedata ||= {};
  $self->_add_data($filename, $data, $filedata->{uid} || 0, $filedata->{gid} || 0, $filedata->{date} || time, $filedata->{mode} || oct(100644));
  use bytes;
  length $data;
}


sub write
{
  my($self, $filename) = @_;
  if(defined $filename)
  {
    my $fh;

    if(ref $filename)
    {
      return $self->_error("Not a filehandle") unless eval{*$filename{IO}} or $filename->isa('IO::Handle');
      $fh = $filename;

      return $self->_write_to_callback(sub {
        my($archive, $buffer) = @_;
        print $fh $buffer;
        length $buffer;
      });
    }

    return $self->_write_to_filename($filename);
  }
  else
  {
    my $content = '';
    my $status = $self->_write_to_callback(sub {
      my($archive, $buffer) = @_;
      $content .= $buffer;
      length $buffer;
    });
    return unless $status;
    return $content;
  }
}


sub get_handle
{
  my $data = shift->get_data(@_);
  return unless defined $data;
  open my $fh, '<', \$data;
  $fh;
}


sub set_output_format_bsd
{
  carp "set_output_format_bsd is deprecated, use \$ar->set_opt(type => BSD) instead";
  shift->set_opt(type => BSD);
}

sub set_output_format_svr4
{
  carp "set_output_format_bsd is deprecated, use \$ar->set_opt(type => COMMON) instead";
  shift->set_opt(type => COMMON);
}

sub DEBUG
{
  carp "DEBUG is deprecated, use \$ar->set_opt(\"warn\", 1) instead";
  my($self, $value) = @_;
  $self->set_opt(warn => 1) unless defined $value and $value == 0;
}

sub _error
{
  my($self, $message) = @_;
  my $opt_warn = $self->get_opt('warn');
  my $longmess = longmess $message;
  $self->_set_error($message, $longmess);
  if($opt_warn > 1)
  {
    carp $longmess;
  }
  elsif($opt_warn)
  {
    carp $message;
  }
  return;
}

1;

__END__