view release on metacpan or  search on metacpan

lib/Archive/Libarchive/ArchiveRead.pm  view on Meta::CPAN

package Archive::Libarchive::ArchiveRead;

use strict;
use warnings;
use 5.020;
use Archive::Libarchive::Lib;
use FFI::Platypus::Buffer qw( scalar_to_buffer scalar_to_pointer grow set_used_length window );
use FFI::Platypus::Memory qw( strdup free );
use Ref::Util qw( is_plain_scalarref is_plain_coderef is_blessed_ref is_plain_arrayref );
use Carp ();
use Scalar::Util qw( refaddr );
use experimental qw( signatures );
use parent qw( Archive::Libarchive::Archive );
use constant;

# ABSTRACT: Libarchive read archive class
our $VERSION = '0.09'; # VERSION

my $ffi = Archive::Libarchive::Lib->ffi;
constant->import(_opaque_size => $ffi->sizeof('opaque'));
my %keep;


$ffi->mangler(sub ($name) { "archive_read_$name"  });

$ffi->attach( new => [] => 'opaque' => sub {
  my($xsub, $class) = @_;
  my $ptr = $xsub->();
  bless { ptr => $ptr }, $class;
});

$ffi->attach( [ free => 'DESTROY' ] => ['archive_read'] => 'int' => sub {
  my($xsub, $self) = @_;
  free delete $self->{passphrase} if defined $self->{passphrase};
  return if $self->{cb}                 # inside a callback, we don't own the archive pointer
    || ${^GLOBAL_PHASE} eq 'DESTRUCT';  # during global shutdown the xsub might go away
  my $ret = $xsub->($self);
  delete $keep{refaddr $self};
  warn "destroying archive pointer did not return ARCHIVE_OK" unless $ret == 0;
});


my %set_callback = map {
  ($_ => $ffi->function( "set_${_}_callback" => ['archive_read',"archive_${_}_callback"] => 'int' )->sub_ref)
} qw( open close read seek skip );

$ffi->attach( [ set_callback_data => '_set_callback_data' ] => ['archive_read','opaque'] => 'int' );

$ffi->attach( [ open1 => 'open' ] => [ 'archive_read'] => 'int' => sub {
  my($xsub, $self, %callbacks) = @_;

  Carp::croak("The read callback is required") unless $callbacks{read};

  foreach my $name (keys %set_callback)
  {
    my $set = $set_callback{$name};
    my $sub = delete $callbacks{$name};

    unless(defined $sub)
    {
      $set->($self, undef);
      next;
    }

    Carp::croak("Callback for $name is not a code reference") unless is_plain_coderef $sub;

    my $closure;

    if($name eq 'read')
    {
      $closure = FFI::Platypus->closure(sub ($r, $, $ptrptr) {
        $r = bless { ptr => $r, cb => 1 }, __PACKAGE__;
        $self->{read_buffer} = undef;
        my $size = $sub->($r, \$self->{read_buffer});
        my $ptr = defined $self->{read_buffer} ? scalar_to_pointer($self->{read_buffer}) : undef;
        _memcpy($ptrptr, [$ptr], _opaque_size());
        return $size;
      });
    }
    else
    {
      $closure = FFI::Platypus->closure(sub ($r, $, @therest) {
        $r = bless { ptr => $r, cb => 1 }, __PACKAGE__;
        $sub->($r, @therest);
      });
    }

    push @{ $keep{refaddr $self} }, $closure;

    $set->($self, $closure);
  }

  Carp::croak("No such read callbacks: @{[ sort keys %callbacks ]}") if %callbacks;

  _set_callback_data($self, undef);

  $xsub->($self);
});


$ffi->attach( open_memory => ['archive_read','opaque','size_t'] => 'int' => sub {
  my($xsub, $self, $ref) = @_;
  Carp::croak("buffer must be a scalar reference")
    unless defined $ref && is_plain_scalarref $ref;
  push @{ $keep{refaddr $self} }, \($$ref);
  my($ptr, $size) = scalar_to_buffer $$ref;
  $xsub->($self, $ptr, $size);
});


$ffi->attach( open_FILE => ['archive_read', 'opaque'] => 'int' => sub {
  my($xsub, $self, $fp) = @_;
  $fp = $$fp if is_blessed_ref $fp && $fp->isa('FFI::C::File');
  $xsub->($self, $fp);
});


sub open_perlfile ($self, $fh)
{
  $self->open(
    read => sub ($r, $ref) {
      return sysread $fh, $$ref, 512;
    },
    close => sub ($r) {
      close $fh;
    },
  );
}


$ffi->attach( open_filenames => ['archive_read', 'string[]', 'size_t'] => 'int' => sub {
  my($xsub, $self, $filenames, $size) = @_;
  Carp::croak("Filenames must be provided as an array reference")
    unless defined $filenames && is_plain_arrayref $filenames;
  $xsub->($self, defined $filenames->[-1] ? [@$filenames, undef] : $filenames, $size);
});


$ffi->attach( [ next_header2 => 'next_header' ] => ['archive_read','archive_entry'] => 'int' => sub {
  my($xsub, $self, $entry) = @_;
  $xsub->($self, $entry);
});


$ffi->attach( [data => 'read_data'] => ['archive_read', 'opaque', 'size_t'] => 'ssize_t' => sub {
  my($xsub, $self, $ref, $size) = @_;
  $size ||= 512;

  grow $$ref, $size, { clear => 0 };
  my $rsize = $xsub->($self, (scalar_to_buffer $$ref));
  set_used_length $$ref, $rsize;

  return $rsize;

lib/Archive/Libarchive/ArchiveRead.pm  view on Meta::CPAN

require Archive::Libarchive::Lib::ArchiveRead unless $Archive::Libarchive::no_gen;

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Archive::Libarchive::ArchiveRead - Libarchive read archive class

=head1 VERSION

version 0.09

=head1 SYNOPSIS

 use 5.020;
 use Archive::Libarchive qw( :const );
 
 my $r = Archive::Libarchive::ArchiveRead->new;
 $r->support_filter_all;
 $r->support_format_all;
 $r->open_filename("archive.tar", 10240) == ARCHIVE_OK
   or die $r->error_string;
 
 my $e = Archive::Libarchive::Entry->new;
 say $e->pathname while $r->next_header($e) == ARCHIVE_OK;

=head1 DESCRIPTION

This class represents an archive instance for reading from archives.

=head1 CONSTRUCTOR

=head2 new

 # archive_read_new
 my $r = Archive::Libarchive::ArchiveRead->new;

Create a new archive read object.

=head1 METHODS

This is a subset of total list of methods available to all archive classes.
For the full list see L<Archive::Libarchive::API/Archive::Libarchive::ArchiveRead>.

=head2 open

 # archive_read_open1
 # archive_read_set_callback_data
 # archive_read_set_close_callback
 # archive_read_set_open_callback
 # archive_read_set_read_callback
 # archive_read_set_seek_callback
 # archive_read_set_skip_callback
 $r->open(%callbacks);

This is a basic open method, which relies on callbacks for its implementation.  The
only callback that is required is the C<read> callback.  The C<open> and C<close>
callbacks are made available mostly for the benefit of the caller.  The C<skip>
and C<seek> callbacks are used if available for some formats like C<zip> to improve
performance.  All callbacks should return a L<normal status code|Archive::Libarchive/CONSTANTS>,
which is C<ARCHIVE_OK> on success.

Unlike the C<libarchive> C-API, this interface doesn't provide a facility for
passing in "client" data.  In Perl this is implemented using a closure, which should
allow you to pass in arbitrary variables via proper scoping.

=over 4

=item open

 $r->open(open => sub ($r) {
   ...
 });

Called immediately when the archive is "opened";

=item read

 $r->open(read => sub ($r, $ref) {
   $$ref = ...;
   ...
   return $size.
 });

Called when new data is required.  What is passed in is a scalar reference.  You should
set this scalar to the next block of data.  On success you should return the size of
the data in bytes, and on failure return a L<normal status code|Archive::Libarchive/CONSTANTS>.

=item seek

 $r->open(seek => sub ($r, $offset, $whence) {
   ...
 });

Called to seek to the new location.  The C<$offset> and C<$whence> arguments work exactly
like the C<libc> C<fseek> function.

=item skip

 $r->open(skip => sub ($r, $request) {
   ...
 });

Called to skip the next C<$request> bytes.  Should return the actual number of bytes skipped
on success (which can be less than or equal to C<$request>), and on failure return a
L<normal status code|Archive::Libarchive/CONSTANTS>.

=item close

 $r->open(close => sub ($r) {
   ...
 });

This is called when the archive instance is closed.

=back

=head2 open_memory

 # archive_write_open_memory