view release on metacpan or  search on metacpan

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

            'posix_extensions' => 1
        );

        $builder->set_handle($fh);

        lives_ok {
            $builder->archive_as( '/etc/hosts' => 'BLEH' x 60 );
        }
        '$builder->archive_as() will NOT croak() on long filenames when posix_extensions is passed';
    }

    close $fh;
}

#
# Test hardlink preservation support
#
{
    my $src  = File::Temp::tempdir( 'CLEANUP' => 1 );
    my $dest = File::Temp::tempdir( 'CLEANUP' => 1 );

    open my $fh, '>', "$src/foo" or die "Unable to open $src/foo for writing: $!";
    print {$fh} "test\n";
    close $fh;

    link "$src/foo" => "$src/bar" or die "Unable to link $src/foo to $src/bar: $!";

    my @FLAG_SETS = (
        [ 'ustar' => [ 'preserve_hardlinks' => 1 ] ],
        [ 'PAX'   => [ 'preserve_hardlinks' => 1, 'posix_extensions' => 1 ] ],
        [ 'GNU'   => [ 'preserve_hardlinks' => 1, 'gnu_extensions' => 1 ] ]
    );

    foreach my $flag_set (@FLAG_SETS) {
        my ( $format, $flags ) = @{$flag_set};

        note("Testing 'preserve_hardlinks' flag with $format output");

        my $builder = Archive::Tar::Builder->new( @{$flags} );

        my $reader_pid = IPC::Open3::open3( my $in, undef, undef, $tar, '-C', $dest, '-xf', '-' );
        my $writer_pid = fork;

        die "Unable to fork(): $!" unless defined $writer_pid;

        if ( $writer_pid == 0 ) {
            chdir $src or die "Unable to chdir() to $src: $!";

            $builder->set_handle($in);
            $builder->archive('.');
            $builder->finish;

            exit 0;
        }

        close $in;

        waitpid $writer_pid, 0 or die "Unable to waitpid() on $writer_pid: $!";
        waitpid $reader_pid, 0 or die "Unable to waitpid() on $reader_pid: $!";

        my @st1 = stat "$dest/foo" or die "Unable to stat() $dest/foo: $!";
        my @st2 = stat "$dest/bar" or die "Unable to stat() $dest/bar: $!";

        is( $st1[0] => $st2[0], "st_dev of $dest/foo matches $dest/bar" );
        is( $st1[1] => $st2[1], "st_ino of $dest/foo matches $dest/bar" );
    }
}

#
# Test for fix to CPANEL-29859; segfaulting when archiving certain numbers of
# hardlinked files
#
{
    my $tmp = File::Temp::tempdir( 'CLEANUP' => 1 );

    for ( my $i = 1; $i < 200; $i++ ) {
        my $orig = sprintf "$tmp/orig-%04d", $i;
        my $link = sprintf "$tmp/link-%04d", $i;

        open my $fh, '>', $orig or die "Unable to open() $orig for writing: $!";
        close $fh;

        link $orig => $link or die "Unable to link() $orig to $link: $!";
    }

    my $status = system $^X, "$FindBin::Bin/scripts/CPANEL-29859.pl", $tmp;
    my $signal = $? & 0x7f;

    is( $signal => 0, "\$builder->archive() exits with no signal when archiving large numbers of hardlinked files" );
}