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