File Coverage

lib/CPANPLUS/Module/Checksums.pm

Criterion	Covered	Total	%
statement	91	112	81.2
branch	35	62	56.4
condition	2	3	66.6
subroutine	13	13	100.0
pod	1	1	100.0
total	142	191	74.3

package CPANPLUS::Module::Checksums;

use strict;
use vars qw[@ISA $VERSION];

use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;

use FileHandle;

use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load];

$Params::Check::VERBOSE = 1;

@ISA = qw[ CPANPLUS::Module::Signature ];
$VERSION = "0.9916";

=head1 NAME

CPANPLUS::Module::Checksums - checking the checksum of a distribution

=head1 SYNOPSIS

    $file   = $modobj->checksums;
    $bool   = $mobobj->_validate_checksum;

=head1 DESCRIPTION

This is a class that provides functions for checking the checksum
of a distribution. Should not be loaded directly, but used via the
interface provided via C.

=head1 METHODS

=head2 $mod->checksums

Fetches the checksums file for this module object.
For the options it can take, see C.

Returns the location of the checksums file on success and false
on error.

The location of the checksums file is also stored as

    $mod->status->checksums

=cut

sub checksums {
    my $mod = shift or return;

    my $file = $mod->_get_checksums_file( @_ );

    return $mod->status->checksums( $file ) if $file;

    return;
}

### checks if the package checksum matches the one
### from the checksums file
sub _validate_checksum {
    my $self = shift; #must be isa CPANPLUS::Module
    my $conf = $self->parent->configure_object;
    my %hash = @_;

    my $verbose;
    my $tmpl = {
        verbose => {    default => $conf->get_conf('verbose'),
                        store   => \$verbose },
    };

    check( $tmpl, \%hash ) or return;

    ### if we can't check it, we must assume it's ok ###
    return $self->status->checksum_ok(1)
            unless can_load( modules => { 'Digest::SHA' => '0.0' } );
    #class CPANPLUS::Module::Status is runtime-generated

    my $file = $self->_get_checksums_file( verbose => $verbose ) or (
        error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return );

    $self->_check_signature_for_checksum_file( file => $file ) or (
        error(loc(q[Could not verify '%1' file], CHECKSUMS)), return );
    #for whole CHECKSUMS file

    my $href = $self->_parse_checksums_file( file => $file ) or (
        error(loc(q[Could not parse '%1' file], CHECKSUMS)), return );

    my $cpan_path = $href->{ $self->package }->{'cpan_path'};

    if ( defined $cpan_path ) {
        my $chk_pth = join '/', 'authors/id', $cpan_path;
        if ( $chk_pth ne $self->path ) {
            error(loc(  "Archive checksum path for '%1': " .
                        "should be '%2', but it says it is '%3'. Abandoning.",
                        $self->package, $self->path, $chk_pth));
            return $self->status->checksum_ok(0);
        }
    }

    my $size = $href->{ $self->package }->{'size'};

    ### the checksums file tells us the size of the archive
    ### but the downloaded file is of different size
    if( defined $size ) {
        if( not (-s $self->status->fetch == $size) ) {
            error(loc(  "Archive size does not match for '%1': " .
                        "size is '%2' but should be '%3'",
                        $self->package, -s $self->status->fetch, $size));
            return $self->status->checksum_ok(0);
        }
    } else {
        msg(loc("Archive size is not known for '%1'",$self->package),$verbose);
    }

    my $sha = $href->{ $self->package }->{'sha256'};

    unless( defined $sha ) {
        msg(loc("No 'sha256' checksum known for '%1'",$self->package),$verbose);

        return $self->status->checksum_ok(1);
    }

    $self->status->checksum_value($sha);


    my $fh = FileHandle->new( $self->status->fetch ) or return;
    binmode $fh;

    my $ctx = Digest::SHA->new(256);
    $ctx->addfile( $fh );

    my $hexdigest = $ctx->hexdigest;
    my $flag = $hexdigest eq $sha;
    $flag
        ? msg(loc("Checksum matches for '%1'", $self->package),$verbose)
        : error(loc("Checksum does not match for '%1': " .
                    "SHA256 is '%2' but should be '%3'",
                    $self->package, $hexdigest, $sha),$verbose);


    return $self->status->checksum_ok(1) if $flag;
    return $self->status->checksum_ok(0);
}


### fetches the module objects checksum file ###
sub _get_checksums_file {
    my $self = shift;
    my %hash = @_;

    my $clone = $self->clone;
    $clone->package( CHECKSUMS );

    # If the user specified a fetchdir, then every CHECKSUMS file will always
    # be stored there, not in an author-specific subdir.  Thus, in this case,
    # we need to always re-fetch the CHECKSUMS file and hence need to set the
    # TTL to something small.
    my $have_fetchdir =
        $self->parent->configure_object->get_conf('fetchdir') ne '';
    my $ttl = $have_fetchdir ? 0.001 : 3600;
    my $file = $clone->fetch( ttl => $ttl, %hash ) or return;

    return $file;
}

sub _parse_checksums_file {
    my $self = shift;
    my %hash = @_;

    my $file;
    my $tmpl = {
        file    => { required => 1, allow => FILE_READABLE, store => \$file },
    };
    my $args = check( $tmpl, \%hash );

    my $fh = OPEN_FILE->( $file ) or return;

    ### loop over the header, there might be a pgp signature ###
    my $signed;
    while (local $_ = <$fh>) {
        last if /^\$cksum = \{\s*$/;    # skip till this line
        my $header = PGP_HEADER;        # but be tolerant of whitespace
        $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks
   }

    ### read the filehandle, parse it rather than eval it, even though it
    ### *should* be valid perl code
    my $dist;
    my $cksum = {};
    while (local $_ = <$fh>) {

        if (/^\s*'([^']+)' => \{\s*$/) {
            $dist = $1;

        } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) {
            $cksum->{$dist}{$1} = $2;

        } elsif (/^\s*}[,;]?\s*$/) {
            undef $dist;

        } elsif (/^__END__\s*$/) {
            last;

        } else {
            error( loc("Malformed %1 line: %2", CHECKSUMS, $_) );
        }
    }

    return $cksum;
}

sub _check_signature_for_checksum_file {
    my $self = shift;

    my $conf = $self->parent->configure_object;
    my %hash = @_;

    ### you don't want to check signatures,
    ### so let's just return true;
    return 1 unless $conf->get_conf('signature');

    my($force,$file,$verbose);
    my $tmpl = {
        file    => { required => 1, allow => FILE_READABLE, store => \$file },
        force   => { default => $conf->get_conf('force'), store => \$force },
        verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
    };

    my $args = check( $tmpl, \%hash ) or return;

    my $fh = OPEN_FILE->($file) or return;

    my $signed;
    while (local $_ = <$fh>) {
        my $header = PGP_HEADER;
        $signed = 1 if /^$header$/;
    }

    if ( !$signed ) {
        msg(loc("No signature found in %1 file '%2'",
                CHECKSUMS, $file), $verbose);

        return 1 unless $force;

        error( loc( "%1 file '%2' is not signed -- aborting",
                    CHECKSUMS, $file ) );
        return;

    }

    if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) {
        # local $Module::Signature::SIGNATURE = $file;
        # ... check signatures ...
    }

    return 1;
}



# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:

1;