view release on metacpan or  search on metacpan

t/001Basic.t  view on Meta::CPAN

note('Iterators');

# required to be invoke since list_all() invokes it implicit
$arch->list_reset();
my @elements;
while ( my $entry = $arch->list_next() ) {
    push @elements, $entry->[0];
}
@elements = sort(@elements);
is_deeply(
    \@elements,
    [qw(001Basic.t foo/bar/baz foo/bar/permtest foo/bar/string)],
    'list_next() produce the expected results'
);

note('Check optional file names for extraction');

my $a3 = Archive::Tar::Wrapper->new();
$a3->read( File::Spec->catfile( TARDIR, 'bar.tar' ), 'bar/bar.dat' );
my $elements = $a3->list_all();
is( scalar(@$elements), 1, 'only one file extracted' );
is( $elements->[0]->[0],
    'bar/bar.dat', 'the first index of list_all() has the expected data' );

note('Ask for non-existent files in tarball');
my $a4 = Archive::Tar::Wrapper->new();

# Suppress the warning
Log::Log4perl->get_logger('')->level($FATAL);

SKIP: {
    skip( 'FreeBSD\'s tar is too lenient - skipping', 1 )
      if ( $^O =~ /freebsd/i );
    skip 'bsdtar is too lenient', 1 if ( $a4->is_bsd() );
    my $rc = $a4->read( File::Spec->catfile( TARDIR, 'bar.tar' ),
        'bar/bar.dat', 'quack/schmack' );
    is( $rc, undef, 'Failure to ask for non-existent files' );
}

note('Testing original file permissions');
umask(022);
my $a5 = Archive::Tar::Wrapper->new( tar_read_options => 'p', );
$a5->read( File::Spec->catfile( TARDIR, 'bar.tar' ) );
$f1 = $a5->locate('bar/bar.dat');

# TODO: add conditional note on Alpine to indicate that tar over there is broken regarding -p parameter
if ($f1) {
    $expected_permission = sprintf '%3o', ( ( stat($f1) )[2] & 07777 );
}
else {
    note( 'Could not locate "bar/bar.dat" inside the tarball '
          . File::Spec->catfile( TARDIR, 'bar.tar' ) );
}

SKIP: {
    skip 'Cannot check permissions on a non-existent file', 1 unless $f1;
    skip 'Permissions are too different on Microsoft Windows', 1
      if ( $Config{osname} eq 'MSWin32' || $Config{osname} eq 'msys' );
    is( $expected_permission, '664', 'testing file permissions' )
      or diag(
'Known bug in Alpine Linux: https://bugs.busybox.net/show_bug.cgi?id=16102'
      );
}

SKIP: {
    # gnu options
    my $a6 =
      Archive::Tar::Wrapper->new( tar_gnu_read_options => ['--numeric-owner'],
      );

    my $is_gnu = $a6->is_gnu();
    note( $a6->{tar_error_msg} ) if ( defined( $a6->{tar_error_msg} ) );

    skip 'Only with gnu tar', 1 unless $is_gnu;

    $a6->read( File::Spec->catfile( TARDIR, 'bar.tar' ) );
    $f1 = $a6->locate('bar/bar.dat');

    ok( defined $f1, 'numeric owner works' );

}

note('Trying to test GNU options');
SKIP: {
    # gnu options
    my $tar =
      Archive::Tar::Wrapper->new( tar_gnu_write_options => ['--exclude=foo'], );

    my $is_gnu = $tar->is_gnu();
    note( $tar->{tar_error_msg} ) if ( defined( $tar->{tar_error_msg} ) );
    skip 'Test is possible only with GNU tar', 1 unless $is_gnu;

    my $file_loc = $tar->locate('001Basic.t');
    $tar->add( 'foo/bar/baz', $0 );
    $tar->add( 'boo/bar/baz', $0 );

    my ( $fh, $filename ) = tempfile( UNLINK => 1, SUFFIX => '.tgz' );
    $tar->write( $filename, 1 );

    my $tar_read = Archive::Tar::Wrapper->new();
    $tar_read->read($filename);

    for my $entry ( @{ $tar_read->list_all() } ) {
        my ( $tar_path, $real_path ) = @$entry;

        is( $tar_path, 'boo/bar/baz', 'foo excluded' );
    }
}