view release on metacpan or  search on metacpan

t/lib-Archive-Tar-Builder.t  view on Meta::CPAN

    open( $fh, '>', $file ) or die("Unable to open $file for writing: $!");
    print {$fh} "Meow\n";
    close $fh;

    return $tmpdir;
}

my $badfile = '/dev/null/impossible';
my $tar     = find_tar();

{
    my $builder = Archive::Tar::Builder->new;

    eval { $builder->archive(); };

    like( $@ => qr/No paths to archive specified/, '$builder->archive() dies if no paths are specified' );

    eval { $builder->archive('foo'); };

    like( $@ => qr/No file handle set/, '$builder->archive() dies if no file handle is set' );

    eval { $builder->archive_as( 'foo' => 'bar' ); };

    like( $@ => qr/No file handle set/, '$builder->archive_as() dies if no file handle is set' );
}

SKIP: {
    skip( 'Cannot test permissions failures as root', 2 ) if $< == 0;

    my $tmp = File::Temp::tempdir( 'CLEANUP' => 1 );
    my $dir = "$tmp/foo";

    mkdir( $dir, 0000 );

    my $builder = Archive::Tar::Builder->new( 'quiet' => 1 );

    open( my $fh, '>', '/dev/null' ) or die("Unable to open /dev/null: $!");

    $builder->set_handle($fh);
    $builder->archive($tmp);

    eval { $builder->finish(); };

    like( $@ => qr/^Delayed nonzero exit/, '$builder->finish() still die()s with "quiet" but not "ignore_errors" for non-fatals' );

    undef $@;

    $builder = Archive::Tar::Builder->new(
        'quiet'         => 1,
        'ignore_errors' => 1
    );

    $builder->set_handle($fh);
    $builder->archive($tmp);

    eval { $builder->finish(); };

    ok( !$@, '$builder->finish() does not die() if "ignore_errors" is set for non-fatals' );

    chmod( 0600, $dir );
}

#
# Test external functionality
#
{
    my $oldpwd = Cwd::getcwd();
    my $tmpdir = build_tree();

    chdir($tmpdir) or die("Unable to chdir() to $tmpdir: $!");

    my $archive = Archive::Tar::Builder->new;

    my %paths = (
        'foo'  => 'foo',
        'bar'  => 'foo',
        'baz'  => 'foo',
        'home' => 'home'
    );

    #
    # Test Archive::Tar::Builder's ability to exclude files
    #
    $archive->exclude_from_file("$tmpdir/foo/exclude.txt");
    $archive->exclude('baz');

    ok( $archive->is_excluded("$tmpdir/baz"),           '$archive->is_excluded() works when excluding added with $archive->exclude()' );
    ok( $archive->is_excluded("$tmpdir/foo/cats/meow"), '$archive->is_excluded() works when exclusion added with $archive->exclude_from_file()' );

    #
    # Test to see the expected contents are written.
    #
    my $reader_pid = IPC::Open3::open3( my ( $in, $out ), undef, $tar, '-tf', '-' );
    my $writer_pid = fork();

    $archive->set_handle($in);

    if ( !defined $writer_pid ) {
        die("Unable to fork(): $!");
    }
    elsif ( $writer_pid == 0 ) {
        close $out;

        foreach my $member ( sort keys %paths ) {
            my $path = $paths{$member};

            $archive->archive_as( $path => $member );
        }

        $archive->finish();

        #
        # This may seem a bit gratuitous, but this is needed because Perl 5.6.2's
        # distribution of File::Temp has a bug in which directories are cleaned
        # up regardless if the process exiting is a child of the process that
        # created the directory in question, or not.  execve() is the easiest way
        # to clear away atexit() handlers in this case.
        #
        exec( '/bin/sh', '-c', 'true' );
    }

t/lib-Archive-Tar-Builder.t  view on Meta::CPAN

    print {$fh} "foo\n";
    print {$fh} "bar\n";
    print {$fh} "baz\n";
    close $fh;

    eval { $archive->include('meow'); };

    is( $@ => '', '$archive->include() does not die when adding inclusion pattern' );

    eval { $archive->include_from_file($badfile); };

    like( $@ => qr/^Cannot add items to inclusion list from file $badfile:/, '$archive->include_from_file() dies on invalid file' );

    eval { $archive->include_from_file($file); };

    is( $@ => '', '$archive->include_from_file() does not die when adding include patterns from file' );

    my %TESTS = (
        'foo'          => 1,
        'bar/poo'      => 1,
        'baz/poo'      => 1,
        'meow/cats'    => 1,
        'haz/meow/poo' => 0,
        'haz/poo/meow' => 0,
        'bleh'         => 0
    );

    foreach my $path ( sort keys %TESTS ) {
        my $should_be_included = $TESTS{$path};

        if ($should_be_included) {
            ok( !$archive->is_excluded($path), "'$path' is included" );
        }
        else {
            ok( $archive->is_excluded($path), "'$path' is not included" );
        }
    }

    unlink($file);
}

# Test error handling
SKIP: {
    skip( 'Test will not work as root', 1 ) unless $<;

    my $tmpdir = File::Temp::tempdir( 'CLEANUP' => 1 );
    my $path   = "$tmpdir/foo";

    mkdir( $path, 0 );

    open( my $fh, '>', '/dev/null' );

    my $builder = Archive::Tar::Builder->new( 'quiet' => 1 );
    $builder->set_handle($fh);
    $builder->archive($tmpdir);

    eval { $builder->finish(); };

    like( $@ => qr/^Delayed nonzero exit/, '$builder->finish() dies if any errors were encountered' );

    chmod( 0600, $path );
}

# Test long filenames, symlinks
foreach my $ext (qw/gnu posix/) {
    my $tmpdir = File::Temp::tempdir( 'CLEANUP' => 1 );
    my $path   = "$tmpdir/" . ( 'foops/' x 60 );

    File::Path::mkpath($path) or die("Unable to create long path: $!");

    my $long_symlink = "${path}foo";
    $long_symlink =~ s/^\///;
    $long_symlink =~ s/\/$//;

    symlink( 'foo',         "$tmpdir/bar" ) or die("Unable to symlink() $tmpdir/bar to foo: $!");
    symlink( $long_symlink, "$tmpdir/baz" ) or die("Unable to symlink() $tmpdir/baz to $long_symlink: $!");

    my $archive = Archive::Tar::Builder->new( "${ext}_extensions" => 1 );

    my $err = Symbol::gensym();

    my $reader_pid = IPC::Open3::open3( my ( $in, $out ), $err, $tar, '-tvf', '-' );
    my $writer_pid = fork();

    if ( !defined $writer_pid ) {
        die("Unable to fork(): $!");
    }
    elsif ( $writer_pid == 0 ) {
        $archive->set_handle($in);
        $archive->archive($tmpdir);
        $archive->flush();
        exec( '/bin/sh', '-c', 'true' );
    }

    my ( $paths, $errors );

    my $rin = '';
    vec( $rin, fileno($out), 1 ) = 1;
    vec( $rin, fileno($err), 1 ) = 1;

    my %FOUND;
    my %SYMLINKS;

    close $in;

    while ( select( my $rout = $rin, undef, undef, undef ) > 0 ) {
        my $buf;
        my $len;

        if ( vec( $rout, fileno($out), 1 ) ) {
            $len = sysread( $out, $buf, 512 );

            if ( !$len ) {
                vec( $rin, fileno($out), 1 ) = 0;
            }
            else {
                $paths .= $buf;
            }
        }

        if ( vec( $rout, fileno($err), 1 ) ) {