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