view release on metacpan or  search on metacpan

lib/Test/Smoke/Syncer/Snapshot.pm  view on Meta::CPAN

    my $remote_archive = "$self->{snapurl}";

    $self->{v} and print "LWP::Simple::mirror($remote_archive)";
    my $result = LWP::Simple::mirror( $remote_archive, $local_archive );
    if ( LWP::Simple::is_success( $result ) ) {
        $self->{v} and print " OK\n";
        return $local_archive;
    } elsif ( LWP::Simple::is_error( $result ) ) {
        $self->{v} and print " not OK\n";
        return undef;
    } else {
        $self->{v} and print " skipped\n";
        return $local_archive;
    }
}


=head2 $syncer->_extract_archive( )

C<_extract_archive()> checks the B<tar> attribute to find out how to
extract the archive. This could be an external command or the
B<Archive::Tar>/B<Comperss::Zlib> modules.

=cut

sub _extract_archive {
    my $self = shift;

    unless ( $self->{archive} && -f $self->{archive} ) {
        require Carp;
        Carp::carp( "No archive to be extracted!" );
        return undef;
    }

    my $cwd = cwd();

    # Files in the archive are relative to the 'perl/' directory,
    # they may need to be moved and that is not easy when you've
    # extracted them in the target directory! so we go updir()
    my $ddir = $^O eq 'VMS' ? $self->{vms_ddir} : $self->{ddir};
    my $extract_base = File::Spec->catdir( $ddir, File::Spec->updir );
    chdir $extract_base or do {
        require Carp;
        Carp::croak( "Can't chdir '$extract_base': $!" );
    };

    my $archive_base;
    EXTRACT: {
        local $_ = $self->{snaptar} || 'Archive::Tar';

        /^Archive::Tar$/ && do {
            $archive_base = $self->_extract_with_Archive_Tar;
            last EXTRACT;
        };

        # assume a commandline template for $self->{tar}
        $archive_base = $self->_extract_with_external;
    }

    $self->_relocate_tree( $archive_base );

    chdir $cwd or do {
        require Carp;
        Carp::croak( "Can't chdir($extract_base) back: $!" );
    };

    1 while unlink $self->{archive};
}

=head2 $syncer->_extract_with_Archive_Tar( )

C<_extract_with_Archive_Tar()> uses the B<Archive::Tar> and
B<Compress::Zlib> modules to extract the archive.
(This tested verry slow on my Linux box!)

=cut

sub _extract_with_Archive_Tar {
    my $self = shift;

    require Archive::Tar;

    my $archive = Archive::Tar->new() or do {
        require Carp;
        Carp::carp( "Can't Archive::Tar->new: " . $Archive::Tar::error );
        return undef;
    };

    $self->{v} and printf "Extracting '$self->{archive}' (%s) ", cwd();
    $archive->read( $self->{archive}, 1 );
    $Archive::Tar::error and do {
        require Carp;
        Carp::carp("Error reading '$self->{archive}': ".$Archive::Tar::error);
        return undef;
    };
    my @files = $archive->list_files;
    $archive->extract( @files );
    $self->{v} and printf "%d items OK.\n", scalar @files;

    ( my $prefix = $files[0] ) =~ s|^([^/]+).+$|$1|;
    my $base_dir = File::Spec->canonpath(File::Spec->catdir( cwd(), $prefix ));
    $self->{v} and print "Archive prefix: '$base_dir'\n";
    return $base_dir;
}

=head2 $syncer->_extract_with_external( )

C<_extract_with_external()> uses C<< $self->{snaptar} >> as a sprintf()
template to build a command. Yes that might be dangerous!

=cut

sub _extract_with_external {
    my $self = shift;

    my @dirs_pre = __get_directory_names();

    if ( $^O ne 'VMS' ) {
        my $command = sprintf $self->{snaptar}, $self->{archive};
        $command .= " $self->{archive}" if $command eq $self->{snaptar};