File Coverage

lib/CPANPLUS/Module/Checksums.pm
Criterion Covered Total %
statement 91 103 88.3
branch 34 56 60.7
condition 2 3 66.7
subroutine 13 13 100.0
pod 1 1 100.0
total 141 176 80.1


line stmt bran cond sub pod time code
1             package CPANPLUS::Module::Checksums;
2              
3 15     15   300 use strict;
  15         207  
  15         233  
4 15     15   223 use vars qw[@ISA];
  15         155  
  15         224  
5              
6              
7 15     15   241 use CPANPLUS::Error;
  15         201  
  15         370  
8 15     15   370 use CPANPLUS::Internals::Constants;
  15         138  
  15         239  
9              
10 15     15   351 use FileHandle;
  15         142  
  15         837  
11              
12 15     15   459 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         149  
  15         242  
13 15     15   325 use Params::Check qw[check];
  15         159  
  15         324  
14 15     15   339 use Module::Load::Conditional qw[can_load];
  15         149  
  15         286  
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 3 50   3 1 55     my $mod = shift or return;
53              
54 3         174     my $file = $mod->_get_checksums_file( @_ );
55              
56 3 50       1162     return $mod->status->checksums( $file ) if $file;
57              
58 0         0     return;
59             }
60              
61             ### checks if the package checksum matches the one
62             ### from the checksums file
63             sub _validate_checksum {
64 13     13   243     my $self = shift; #must be isa CPANPLUS::Module
65 13         518     my $conf = $self->parent->configure_object;
66 13         495     my %hash = @_;
67              
68 13         153     my $verbose;
69 13         319     my $tmpl = {
70                     verbose => { default => $conf->get_conf('verbose'),
71                                     store => \$verbose },
72                 };
73              
74 13 50       1490     check( $tmpl, \%hash ) or return;
75              
76             ### if we can't check it, we must assume it's ok ###
77 13 50       1506     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 13 50       1739     my $file = $self->_get_checksums_file( verbose => $verbose ) or (
82                     error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return );
83              
84 13 50       8130     $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 13 50       796     my $href = $self->_parse_checksums_file( file => $file ) or (
89                     error(loc(q[Could not parse '%1' file], CHECKSUMS)), return );
90              
91 13         784     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 13 50       141     if( defined $size ) {
96 13 50       172         if( not (-s $self->status->fetch == $size) ) {
97 0         0             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 0         0             return $self->status->checksum_ok(0);
101                     }
102                 } else {
103 0         0         msg(loc("Archive size is not known for '%1'",$self->package),$verbose);
104                 }
105                 
106 13         200     my $md5 = $href->{ $self->package }->{'md5'};
107              
108 13 50       145     unless( defined $md5 ) {
109 0         0         msg(loc("No 'md5' checksum known for '%1'",$self->package),$verbose);
110              
111 0         0         return $self->status->checksum_ok(1);
112                 }
113              
114 13         400     $self->status->checksum_value($md5);
115              
116              
117 13 50       164     my $fh = FileHandle->new( $self->status->fetch ) or return;
118 13         7441     binmode $fh;
119              
120 13         4233     my $ctx = Digest::MD5->new;
121 13         3045     $ctx->addfile( $fh );
122              
123 13         350     my $flag = $ctx->hexdigest eq $md5;
124 13 50       270     $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 13 50       574     return $self->status->checksum_ok(1) if $flag;
132 0         0     return $self->status->checksum_ok(0);
133             }
134              
135              
136             ### fetches the module objects checksum file ###
137             sub _get_checksums_file {
138 24     24   405     my $self = shift;
139 24         466     my %hash = @_;
140              
141 24         1110     my $clone = $self->clone;
142 24         818     $clone->package( CHECKSUMS );
143              
144 24 50       537     my $file = $clone->fetch( %hash, force => 1 ) or return;
145              
146 24         841     return $file;
147             }
148              
149             sub _parse_checksums_file {
150 15     15   206     my $self = shift;
151 15         379     my %hash = @_;
152              
153 15         183     my $file;
154 15         782     my $tmpl = {
155                     file => { required => 1, allow => FILE_READABLE, store => \$file },
156                 };
157 15         983     my $args = check( $tmpl, \%hash );
158              
159 15 50       1305     my $fh = OPEN_FILE->( $file ) or return;
160              
161             ### loop over the header, there might be a pgp signature ###
162 15         258     my $signed;
163 15         1911     while (<$fh>) {
164 90 100       2308         last if /^\$cksum = \{\s*$/; # skip till this line
165 75         1004         my $header = PGP_HEADER; # but be tolerant of whitespace
166 75 100       2715         $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 15         128     my $dist;
172 15         246     my $cksum = {};
173 15         223     while (<$fh>) {
174              
175 1188 100 66     26014         if (/^\s*'([^']+)' => \{\s*$/) {
    100          
    100          
    50          
176 193         3203             $dist = $1;
177              
178                     } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) {
179 772         21937             $cksum->{$dist}{$1} = $2;
180              
181                     } elsif (/^\s*}[,;]?\s*$/) {
182 208         2541             undef $dist;
183              
184                     } elsif (/^__END__\s*$/) {
185 15         144             last;
186              
187                     } else {
188 0         0             error( loc("Malformed %1 line: %2", CHECKSUMS, $_) );
189                     }
190                 }
191              
192 15         223     return $cksum;
193             }
194              
195             sub _check_signature_for_checksum_file {
196 13     13   290     my $self = shift;
197              
198 13         456     my $conf = $self->parent->configure_object;
199 13         323     my %hash = @_;
200              
201             ### you don't want to check signatures,
202             ### so let's just return true;
203 13 100       324     return 1 unless $conf->get_conf('signature');
204              
205 3         119     my($force,$file,$verbose);
206 3         205     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 3 50       293     my $args = check( $tmpl, \%hash ) or return;
213              
214 3 50       250     my $fh = OPEN_FILE->($file) or return;
215              
216 3         33     my $signed;
217 3         506     while (<$fh>) {
218 81         731         my $header = PGP_HEADER;
219 81 100       1365         $signed = 1 if /^$header$/;
220                 }
221              
222 3 50       40     if ( !$signed ) {
223 0         0         msg(loc("No signature found in %1 file '%2'",
224                             CHECKSUMS, $file), $verbose);
225              
226 0 0       0         return 1 unless $force;
227              
228 0         0         error( loc( "%1 file '%2' is not signed -- aborting",
229                                 CHECKSUMS, $file ) );
230 0         0         return;
231              
232                 }
233              
234 3 50       383     if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) {
235             # local $Module::Signature::SIGNATURE = $file;
236             # ... check signatures ...
237                 }
238              
239 3         62     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;
252