view release on metacpan or  search on metacpan

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

package Archive::Libarchive::ArchiveWrite;

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

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

my $ffi = Archive::Libarchive::Lib->ffi;
my %keep;


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

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

$ffi->attach( [ free => 'DESTROY' ] => ['archive_write'] => '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;
});


$ffi->attach( open => ['archive_write', 'opaque', 'archive_open_callback', 'archive_write_callback', 'archive_close_callback'] => 'int' => sub {
  my($xsub, $self, %cb) = @_;

  foreach my $name (qw( open write close ))
  {
    if(defined $cb{$name} && !is_plain_coderef $cb{$name})
    {
      Carp::croak("The $name callback is not a subref");
    }
  }

  my $opener = delete $cb{open};
  my $writer = delete $cb{write};
  my $closer = delete $cb{close};

  Carp::croak("Write callback is required") unless $writer;
  Carp::croak("No such write callbacks: @{[ sort keys %cb ]}") if %cb;

  if($opener)
  {
    my $orig = $opener;
    $opener = FFI::Platypus->closure(sub ($w, $) {
      $w = bless { ptr => $w, cb => 1 }, __PACKAGE__;
      $orig->($w);
    });
    push @{ $keep{refaddr $self} }, $opener;
  }

  if($writer)
  {
    my $orig = $writer;
    $writer = FFI::Platypus->closure(sub ($w, $, $ptr, $size) {
      $w = bless { ptr => $w, cb => 1 }, __PACKAGE__;
      my $buffer;
      window $buffer, $ptr, $size;
      $orig->($w, \$buffer);
    });
    push @{ $keep{refaddr $self} }, $writer;
  }

  if($closer)
  {
    my $orig = $closer;
    $closer = FFI::Platypus->closure(sub ($w, $) {
      $w = bless { ptr => $w, cb => 1 }, __PACKAGE__;
      $orig->($w);
    });
    push @{ $keep{refaddr $self} }, $closer;
  }

  $xsub->($self, undef, $opener, $writer, $closer);
});


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


sub open_memory ($self, $image)
{
  # TODO: it would be nice to pre-allocate $$ref with grow (FFI::Platypus::Buffer)
  # but that gave me scary errors, so look into it later.
  $self->open(
    write => sub ($w, $ref) {
      $$image .= $$ref;
      return length $$ref;
    },
  );
}


sub open_perlfile ($self, $fh)
{
  $self->open(

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

=pod

=encoding UTF-8

=head1 NAME

Archive::Libarchive::ArchiveWrite - Libarchive write archive class

=head1 VERSION

version 0.09

=head1 SYNOPSIS

 use 5.020;
 use Archive::Libarchive;
 use Path::Tiny qw( path );
 
 my $w = Archive::Libarchive::ArchiveWrite->new;
 $w->set_format_pax_restricted;
 $w->open_filename("outarchive.tar");
 
 path('.')->visit(sub ($path, $) {
   my $path = shift;
 
   return if $path->is_dir;
 
   my $e = Archive::Libarchive::Entry->new;
   $e->set_pathname("$path");
   $e->set_size(-s $path);
   $e->set_filetype('reg');
   $e->set_perm( oct('0644') );
   $w->write_header($e);
   $w->write_data(\$path->slurp_raw);
 
 }, { recurse => 1 });
 
 $w->close;

=head1 DESCRIPTION

This class represents an archive instance for writing to archives.

=head1 CONSTRUCTOR

=head2 new

 # archive_write_new
 my $w = Archive::Libarchive::ArchiveWrite->new;

Create a new archive write 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::ArchiveWrite>.

=head2 open

 # archive_write_open
 $w->open(%callbacks);

This is a basic open method, which relies on callbacks for its implementation.  The
only callback that is required is the C<write> callback.  The C<open> and C<close>
callbacks are made available mostly for the benefit of the caller.  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

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

Called immediately when the archive is "opened";

=item write

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

This callback is called when data needs to be written to the archive.  It is passed in
as a reference to a scalar that contains the raw data.  On success you should return the actual size of
the data written in bytes, and on failure return a L<normal status code|Archive::Libarchive/CONSTANTS>.

=item close

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

This is called when the archive instance is closed.

=back

=head2 open_FILE

 # archive_write_open_FILE
 $w->open_FILE($file_pointer);

This takes either a L<FFI::C::File>, or an opaque pointer to a libc file pointer.

=head2 open_memory

 # archive_write_open_memory
 $w->open_memory(\$buffer);

This takes a reference to scalar and stores the archive in memory there.

=head2 open_perlfile

 $w->open_perlfile(*FILE);

This takes a perl file handle and stores the archive there.

=head2 write_data