/usr/share/doc/libffi-platypus-perl/examples/archive.pl is in libffi-platypus-perl 0.45-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | use strict;
use warnings;
use FFI::Platypus ();
use FFI::Platypus::API ();
use FFI::CheckLib ();
# This example uses FreeBSD's libarchive to list the contents of any
# archive format that it suppors. We've also filled out a part of
# the ArchiveWrite class that could be used for writing archive formats
# supported by libarchive
my $ffi = My::Platypus->new;
$ffi->lib(FFI::CheckLib::find_lib_or_exit lib => 'archive');
$ffi->custom_type(archive => {
native_type => 'opaque',
perl_to_native => sub { ${$_[0]} },
native_to_perl => sub {
# this works because archive_read_new ignores any arguments
# and we pass in the class name which we can get here.
my $class = FFI::Platypus::API::arguments_get_string(0);
bless \$_[0], $class;
},
});
$ffi->custom_type(archive_entry => {
native_type => 'opaque',
perl_to_native => sub { ${$_[0]} },
native_to_perl => sub {
# works likewise for archive_entry objects
my $class = FFI::Platypus::API::arguments_get_string(0);
bless \$_[0], $class,
},
});
package My::Platypus;
use base qw( FFI::Platypus );
sub find_symbol
{
my($self, $name) = @_;
my $prefix = lcfirst caller(2);
$prefix =~ s{([A-Z])}{"_" . lc $1}eg;
$self->SUPER::find_symbol(join '_', $prefix, $name);
}
package Archive;
# base class is "abstract" having no constructor or destructor
$ffi->attach( error_string => ['archive'] => 'string' );
package ArchiveRead;
our @ISA = qw( Archive );
$ffi->attach( new => ['string'] => 'archive' );
$ffi->attach( [ free => 'DESTROY' ] => ['archive'] => 'void' );
$ffi->attach( support_filter_all => ['archive'] => 'int' );
$ffi->attach( support_format_all => ['archive'] => 'int' );
$ffi->attach( open_filename => ['archive','string','size_t'] => 'int' );
$ffi->attach( next_header2 => ['archive', 'archive_entry' ] => 'int' );
$ffi->attach( data_skip => ['archive'] => 'int' );
# ... define additional read methods
package ArchiveWrite;
our @ISA = qw( Archive );
$ffi->attach( new => ['string'] => 'archive' );
$ffi->attach( [ free => 'DESTROY' ] => ['archive'] => 'void' );
# ... define additional write methods
package ArchiveEntry;
$ffi->attach( new => ['string'] => 'archive_entry' );
$ffi->attach( [ free => 'DESTROY' ] => ['archive_entry'] => 'void' );
$ffi->attach( pathname => ['archive_entry'] => 'string' );
# ... define additional entry methods
package main;
use constant ARCHIVE_OK => 0;
# this is a Perl version of the C code here:
# https://github.com/libarchive/libarchive/wiki/Examples#List_contents_of_Archive_stored_in_File
my $archive_filename = shift @ARGV;
unless(defined $archive_filename)
{
print "usage: $0 archive.tar\n";
exit;
}
my $archive = ArchiveRead->new;
$archive->support_filter_all;
$archive->support_format_all;
my $r = $archive->open_filename($archive_filename, 1024);
die "error opening $archive_filename: ", $archive->error_string
unless $r == ARCHIVE_OK;
my $entry = ArchiveEntry->new;
while($archive->next_header2($entry) == ARCHIVE_OK)
{
print $entry->pathname, "\n";
$archive->data_skip;
}
|