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;
  }