lib/CPANPLUS/Module/Checksums.pm

   1 package CPANPLUS::Module::Checksums;
   2
   3 use strict;
   4 use vars qw[@ISA];
   5
   6
   7 use CPANPLUS::Error;
   8 use CPANPLUS::Internals::Constants;
   9
  10 use FileHandle;
  11
  12 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  13 use Params::Check               qw[check];
  14 use Module::Load::Conditional   qw[can_load];
  15
  16 $Params::Check::VERBOSE = 1;
  17
  18 @ISA = qw[ CPANPLUS::Module::Signature ];
  19
  20 =head1 NAME
  21
  22 CPANPLUS::Module::Checksums
  23
  24 =head1 SYNOPSIS
  25
  26     $file   = $modobj->checksums;
  27     $bool   = $mobobj->_validate_checksum;
  28
  29 =head1 DESCRIPTION
  30
  31 This is a class that provides functions for checking the checksum
  32 of a distribution. Should not be loaded directly, but used via the
  33 interface provided via C<CPANPLUS::Module>.
  34
  35 =head1 METHODS
  36
  37 =head2 $mod->checksums
  38
  39 Fetches the checksums file for this module object.
  40 For the options it can take, see C<CPANPLUS::Module::fetch()>.
  41
  42 Returns the location of the checksums file on success and false
  43 on error.
  44
  45 The location of the checksums file is also stored as
  46
  47     $mod->status->checksums
  48
  49 =cut
  50
  51 sub checksums {
  52     my $mod = shift or return;
  53
  54     my $file = $mod->_get_checksums_file( @_ );
  55
  56     return $mod->status->checksums( $file ) if $file;
  57
  58     return;
  59 }
  60
  61 ### checks if the package checksum matches the one
  62 ### from the checksums file
  63 sub _validate_checksum {
  64     my $self = shift; #must be isa CPANPLUS::Module
  65     my $conf = $self->parent->configure_object;
  66     my %hash = @_;
  67
  68     my $verbose;
  69     my $tmpl = {
  70         verbose => {    default => $conf->get_conf('verbose'),
  71                         store   => \$verbose },
  72     };
  73
  74     check( $tmpl, \%hash ) or return;
  75
  76     ### if we can't check it, we must assume it's ok ###
  77     return $self->status->checksum_ok(1)
  78             unless can_load( modules => { 'Digest::MD5' => '0.0' } );
  79     #class CPANPLUS::Module::Status is runtime-generated
  80
  81     my $file = $self->_get_checksums_file( verbose => $verbose ) or (
  82         error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return );
  83
  84     $self->_check_signature_for_checksum_file( file => $file ) or (
  85         error(loc(q[Could not verify '%1' file], CHECKSUMS)), return );
  86     #for whole CHECKSUMS file
  87
  88     my $href = $self->_parse_checksums_file( file => $file ) or (
  89         error(loc(q[Could not parse '%1' file], CHECKSUMS)), return );
  90
  91     my $size = $href->{ $self->package }->{'size'};
  92
  93     ### the checksums file tells us the size of the archive
  94     ### but the downloaded file is of different size
  95     if( defined $size ) {
  96         if( not (-s $self->status->fetch == $size) ) {
  97             error(loc(  "Archive size does not match for '%1': " .
  98                         "size is '%2' but should be '%3'",
  99                         $self->package, -s $self->status->fetch, $size));
 100             return $self->status->checksum_ok(0);
 101         }
 102     } else {
 103         msg(loc("Archive size is not known for '%1'",$self->package),$verbose);
 104     }
 105
 106     my $md5 = $href->{ $self->package }->{'md5'};
 107
 108     unless( defined $md5 ) {
 109         msg(loc("No 'md5' checksum known for '%1'",$self->package),$verbose);
 110
 111         return $self->status->checksum_ok(1);
 112     }
 113
 114     $self->status->checksum_value($md5);
 115
 116
 117     my $fh = FileHandle->new( $self->status->fetch ) or return;
 118     binmode $fh;
 119
 120     my $ctx = Digest::MD5->new;
 121     $ctx->addfile( $fh );
 122
 123     my $flag = $ctx->hexdigest eq $md5;
 124     $flag
 125         ? msg(loc("Checksum matches for '%1'", $self->package),$verbose)
 126         : error(loc("Checksum does not match for '%1': " .
 127                     "MD5 is '%2' but should be '%3'",
 128                     $self->package, $ctx->hexdigest, $md5),$verbose);
 129
 130
 131     return $self->status->checksum_ok(1) if $flag;
 132     return $self->status->checksum_ok(0);
 133 }
 134
 135
 136 ### fetches the module objects checksum file ###
 137 sub _get_checksums_file {
 138     my $self = shift;
 139     my %hash = @_;
 140
 141     my $clone = $self->clone;
 142     $clone->package( CHECKSUMS );
 143
 144     my $file = $clone->fetch( ttl => 3600, %hash ) or return;
 145
 146     return $file;
 147 }
 148
 149 sub _parse_checksums_file {
 150     my $self = shift;
 151     my %hash = @_;
 152
 153     my $file;
 154     my $tmpl = {
 155         file    => { required => 1, allow => FILE_READABLE, store => \$file },
 156     };
 157     my $args = check( $tmpl, \%hash );
 158
 159     my $fh = OPEN_FILE->( $file ) or return;
 160
 161     ### loop over the header, there might be a pgp signature ###
 162     my $signed;
 163     while (local $_ = <$fh>) {
 164         last if /^\$cksum = \{\s*$/;    # skip till this line
 165         my $header = PGP_HEADER;        # but be tolerant of whitespace
 166         $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks
 167    }
 168
 169     ### read the filehandle, parse it rather than eval it, even though it
 170     ### *should* be valid perl code
 171     my $dist;
 172     my $cksum = {};
 173     while (local $_ = <$fh>) {
 174
 175         if (/^\s*'([^']+)' => \{\s*$/) {
 176             $dist = $1;
 177
 178         } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) {
 179             $cksum->{$dist}{$1} = $2;
 180
 181         } elsif (/^\s*}[,;]?\s*$/) {
 182             undef $dist;
 183
 184         } elsif (/^__END__\s*$/) {
 185             last;
 186
 187         } else {
 188             error( loc("Malformed %1 line: %2", CHECKSUMS, $_) );
 189         }
 190     }
 191
 192     return $cksum;
 193 }
 194
 195 sub _check_signature_for_checksum_file {
 196     my $self = shift;
 197
 198     my $conf = $self->parent->configure_object;
 199     my %hash = @_;
 200
 201     ### you don't want to check signatures,
 202     ### so let's just return true;
 203     return 1 unless $conf->get_conf('signature');
 204
 205     my($force,$file,$verbose);
 206     my $tmpl = {
 207         file    => { required => 1, allow => FILE_READABLE, store => \$file },
 208         force   => { default => $conf->get_conf('force'), store => \$force },
 209         verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
 210     };
 211
 212     my $args = check( $tmpl, \%hash ) or return;
 213
 214     my $fh = OPEN_FILE->($file) or return;
 215
 216     my $signed;
 217     while (local $_ = <$fh>) {
 218         my $header = PGP_HEADER;
 219         $signed = 1 if /^$header$/;
 220     }
 221
 222     if ( !$signed ) {
 223         msg(loc("No signature found in %1 file '%2'",
 224                 CHECKSUMS, $file), $verbose);
 225
 226         return 1 unless $force;
 227
 228         error( loc( "%1 file '%2' is not signed -- aborting",
 229                     CHECKSUMS, $file ) );
 230         return;
 231
 232     }
 233
 234     if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) {
 235         # local $Module::Signature::SIGNATURE = $file;
 236         # ... check signatures ...
 237     }
 238
 239     return 1;
 240 }
 241
 242
 243
 244 # Local variables:
 245 # c-indentation-style: bsd
 246 # c-basic-offset: 4
 247 # indent-tabs-mode: nil
 248 # End:
 249 # vim: expandtab shiftwidth=4:
 250
 251 1;