File Coverage

blib/lib/Archive/Libarchive/FFI/Callback.pm

Criterion	Covered	Total	%
statement	30	39	76.9
branch	1	6	16.6
condition	1	3	33.3
subroutine	10	12	83.3
pod	0	2	0.0
total	42	62	67.7

package Archive::Libarchive::FFI::Callback;

use strict;
use warnings;

# ABSTRACT: Libarchive callbacks
our $VERSION = '0.0900'; # VERSION

package
  Archive::Libarchive::FFI;

BEGIN {

  if(eval { require FFI::Sweet })
  {
    FFI::Sweet->import;
  }
  else
  {
    require Archive::Libarchive::FFI::SweetLite;
    Archive::Libarchive::FFI::SweetLite->import;
  }
}
use FFI::Util qw( deref_ptr_set _size_t );

use constant {
  CB_DATA        => 0,
  CB_READ        => 1,
  CB_CLOSE       => 2,
  CB_OPEN        => 3,
  CB_WRITE       => 4,
  CB_SKIP        => 5,
  CB_SEEK        => 6,
  CB_SWITCH      => 7,
  CB_BUFFER      => 8,
};

my %callbacks;

do {
  no warnings 'redefine';
  sub _attach_function ($$$;$)
  {
    eval {
      attach_function($_[0], $_[1], $_[2], $_[3]);
    };
    warn $@ if $@ && $ENV{ARCHIVE_LIBARCHIVE_FFI_VERBOSE};
  }
};

my $myopen = FFI::Raw::Callback->new(sub {
  my($archive) = @_;
  my $status = eval {
    $callbacks{$archive}->[CB_OPEN]->($archive, $callbacks{$archive}->[CB_DATA]);
  };
  if($@)
  {
    warn $@;
    return ARCHIVE_FATAL();
  }
  $status;
}, _int, _ptr, _ptr);

my $mywrite = FFI::Raw::Callback->new(sub
{
  my($archive, $null, $ptr, $size) = @_;
  my $buffer = buffer_to_scalar($ptr, $size);
  my $status = eval {
    $callbacks{$archive}->[CB_WRITE]->($archive, $callbacks{$archive}->[CB_DATA], $buffer);
  };
  if($@)
  {
    warn $@;
    return ARCHIVE_FATAL();
  }
  $status;
}, _int, _ptr, _ptr, _ptr, _size_t);

my $myread = FFI::Raw::Callback->new(sub
{
  my($archive, $null, $optr) = @_;
  my($status, $buffer) = eval {
    $callbacks{$archive}->[CB_READ]->($archive, $callbacks{$archive}->[CB_DATA]);
  };
  if($@)
  {
    warn $@;
    return ARCHIVE_FATAL();
  }
  my($ptr, $size) = scalar_to_buffer($buffer);
  deref_ptr_set($optr, $ptr);
  $size;
}, _uint64, _ptr, _ptr, _ptr);

my $myskip = FFI::Raw::Callback->new(sub
{
  my($archive, $null, $request) = @_;
  my $status = eval {
    $callbacks{$archive}->[CB_SKIP]->($archive, $callbacks{$archive}->[CB_DATA], $request);
  };
  if($@)
  {
    warn $@;
    return ARCHIVE_FATAL();
  }
  $status;
}, _uint64, _ptr, _ptr, _uint64);

my $myseek = FFI::Raw::Callback->new(sub
{
  my($archive, $null, $offset, $whence) = @_;
  my $status = eval {
    $callbacks{$archive}->[CB_SEEK]->($archive, $callbacks{$archive}->[CB_DATA], $offset, $whence);
  };
  if($@)
  {
    warn $@;
    return ARCHIVE_FATAL();
  }
  $status;
}, _uint64, _ptr, _ptr, _uint64, _int);

my $myclose = FFI::Raw::Callback->new(sub
{
  my($archive) = @_;
  my $status = eval {
    $callbacks{$archive}->[CB_CLOSE]->($archive, $callbacks{$archive}->[CB_DATA]);
  };
  if($@)
  {
    warn $@;
    return ARCHIVE_FATAL();
  }
  $status;
}, _int, _ptr, _ptr);

_attach_function 'archive_write_open', [ _ptr, _ptr, _ptr, _ptr, _ptr ], _int, sub
{
  my($cb, $archive, $cd, $open, $write, $close) = @_;
  $callbacks{$archive}->[CB_DATA] = $cd;
  if(defined $open)
  {
    $callbacks{$archive}->[CB_OPEN] = $open;
    $open = $myopen;
  }
  if(defined $write)
  {
    $callbacks{$archive}->[CB_WRITE] = $write;
    $write = $mywrite;
  }
  if(defined $close)
  {
    $callbacks{$archive}->[CB_CLOSE] = $close;
    $close = $myclose;
  }
  $cb->($archive, undef, $open||0, $write||0, $close||0);
};

sub archive_read_open ($$$$$)
{
  my($archive, $data, $open, $read, $close) = @_;
  archive_read_open2($archive, $data, $open, $read, undef, $close);
}

_attach_function 'archive_read_open2', [ _ptr, _ptr, _ptr, _ptr, _ptr, _ptr ], _int, sub
{
  my($cb, $archive, $cd, $open, $read, $skip, $close) = @_;
  $callbacks{$archive}->[CB_DATA] = $cd;
  if(defined $open)
  {
    $callbacks{$archive}->[CB_OPEN] = $open;
    $open = $myopen;
  }
  if(defined $read)
  {
    $callbacks{$archive}->[CB_READ] = $read;
    $read = $myread;
  }
  if(defined $skip)
  {
    $callbacks{$archive}->[CB_SKIP] = $skip;
    $skip = $myskip;
  }
  if(defined $close)
  {
    $callbacks{$archive}->[CB_CLOSE] = $close;
    $close = $myclose;
  }
  $cb->($archive, undef, $open||0, $read||0, $skip||0, $close||0);
};

sub archive_read_set_callback_data ($$)
{
  my($archive, $data) = @_;
  $callbacks{$archive}->[CB_DATA] = $data;
  ARCHIVE_OK();
}

foreach my $name (qw( open read skip close seek ))
{
  my $const = 'CB_' . uc $name;
  my $wrapper = eval '# line '. __LINE__ . ' "' . __FILE__ . "\n" . qq{
    sub
    {
      my(\$cb, \$archive, \$callback) = \@_;
      \$callbacks{\$archive}->[$const] = \$callback;
      \$cb->(\$archive, \$my$name);
    }
  };die $@ if $@;

  _attach_function "archive_read_set_$name\_callback", [ _ptr, _ptr ], _int;
}

if(archive_version_number() >= 3000000)
{
  _attach_function 'archive_read_open_memory', [ _ptr, _ptr, _size_t ], _int, sub
  {
    my($cb, $archive, $buffer) = @_;
    my $length = do { use bytes; length $buffer };
    my $ptr = FFI::Raw::MemPtr->new_from_buf($buffer, $length);
    $callbacks{$archive}->[CB_BUFFER] = $ptr;  # TODO: CB_BUFFER or CB_DATA (or something else?)
    $cb->($archive, $ptr, $length);
  };
}
else
{
  sub _archive_read_open_memory_read
  {
    my($archive, $data) = @_;
    if($data->{done})
    {
      return (ARCHIVE_OK(), '');
    }
    else
    {
      $data->{done} = 1;
      return (ARCHIVE_OK(), $data->{buffer});
    }
  }

  *archive_read_open_memory = sub ($$) {
    my($archive, $buffer) = @_;
    my $r = archive_read_open($archive, { buffer => $buffer, done => 0 }, undef, \&_archive_read_open_memory_read, undef);
    unless($r == ARCHIVE_OK())
    {
      warn "error: " . archive_error_string($archive);
    }
    $r;
  };
}

_attach_function archive_version_number() >= 3000000 ? 'archive_read_free' : [ archive_read_finish => 'archive_read_free' ], [ _ptr ], _int, sub
{
  my($cb, $archive) = @_;
  my $ret = $cb->($archive);
  delete $callbacks{$archive};
  $ret;
};

_attach_function archive_version_number() >= 3000000 ? 'archive_write_free' : [ archive_write_finish => 'archive_write_free' ], [ _ptr ], _int, sub
{
  my($cb, $archive) = @_;
  my $ret = $cb->($archive);
  delete $callbacks{$archive};
  $ret;
};

my %lookups;

use constant {
  CB_LOOKUP_USER  => 0,
  CB_LOOKUP_GROUP => 1,
};

my $mylook_write_user_lookup = FFI::Raw::Callback->new(sub {
  my($archive, $name, $id) = @_;
  my($data, $look_cb, $clean_cb) = @{ $lookups{$archive}->[CB_LOOKUP_USER] };
  return $id unless defined $look_cb;
  $look_cb->($data, $name, $id);
}, _int64, _ptr, _str, _int64);

my $mylook_write_group_lookup = FFI::Raw::Callback->new(sub {
  my($archive, $name, $id) = @_;
  my($data, $look_cb, $clean_cb) = @{ $lookups{$archive}->[CB_LOOKUP_GROUP] };
  return $id unless defined $look_cb;
  $look_cb->($data, $name, $id);
}, _int64, _ptr, _str, _int64);

my $mylook_read_user_lookup = FFI::Raw::Callback->new(sub {
  my($archive, $id) = @_;
  my($data, $look_cb, $clean_cb) = @{ $lookups{$archive}->[CB_LOOKUP_USER] };
  return undef unless defined $look_cb;
  my $name = $look_cb->($data, $id);
  return $name if defined $name;
  return;
}, _str, _ptr, _int64);

my $mylook_read_group_lookup = FFI::Raw::Callback->new(sub {
  my($archive, $id) = @_;
  my($data, $look_cb, $clean_cb) = @{ $lookups{$archive}->[CB_LOOKUP_GROUP] };
  return undef unless defined $look_cb;
  my $name = $look_cb->($data, $id);
  return $name if defined $name;
  return;
}, _str, _ptr, _int64);

my $mylook_user_cleanup = FFI::Raw::Callback->new(sub {
  my($archive) = @_;
  my($data, $look_cb, $clean_cb) = @{ $lookups{$archive}->[CB_LOOKUP_USER] };
  $clean_cb->($data) if defined $clean_cb;
  delete $lookups{$archive};
}, _void, _ptr);

my $mylook_group_cleanup = FFI::Raw::Callback->new(sub {
  my($archive) = @_;
  my($data, $look_cb, $clean_cb) = @{ $lookups{$archive}->[CB_LOOKUP_GROUP] };
  $clean_cb->($data) if defined $clean_cb;
  delete $lookups{$archive};
}, _void, _ptr);

_attach_function 'archive_write_disk_set_user_lookup', [ _ptr, _ptr, _ptr, _ptr ], _int, sub
{
  my($cb, $archive, $data, $look_cb, $clean_cb) = @_;
  if(defined $look_cb || defined $clean_cb)
  {
    $lookups{$archive}->[CB_LOOKUP_USER] = [ $data, $look_cb, $clean_cb ];
    return $cb->($archive, $archive, $mylook_write_user_lookup, $mylook_user_cleanup);
  }
  return $cb->($archive, undef, undef, undef);
};

_attach_function 'archive_write_disk_set_group_lookup', [ _ptr, _ptr, _ptr, _ptr ], _int, sub
{
  my($cb, $archive, $data, $look_cb, $clean_cb) = @_;
  if(defined $look_cb || defined $clean_cb)
  {
    $lookups{$archive}->[CB_LOOKUP_GROUP] = [ $data, $look_cb, $clean_cb ];
    return $cb->($archive, $archive, $mylook_write_group_lookup, $mylook_group_cleanup);
  }
  return $cb->($archive, undef, undef, undef);
};

_attach_function 'archive_read_disk_set_uname_lookup', [ _ptr, _ptr, _ptr, _ptr ], _int, sub
{
  my($cb, $archive, $data, $look_cb, $clean_cb) = @_;
  if(defined $look_cb || defined $clean_cb)
  {
    $lookups{$archive}->[CB_LOOKUP_USER] = [ $data, $look_cb, $clean_cb ];
    return $cb->($archive, $archive, $mylook_read_user_lookup, $mylook_user_cleanup);
  }
  return $cb->($archive, undef, undef, undef);
};

_attach_function 'archive_read_disk_set_gname_lookup', [ _ptr, _ptr, _ptr, _ptr ], _int, sub
{
  my($cb, $archive, $data, $look_cb, $clean_cb) = @_;
  if(defined $look_cb || defined $clean_cb)
  {
    $lookups{$archive}->[CB_LOOKUP_GROUP] = [ $data, $look_cb, $clean_cb ];
    return $cb->($archive, $archive, $mylook_read_group_lookup, $mylook_group_cleanup);
  }
  return $cb->($archive, undef, undef, undef);
};

1;

__END__