Commit | Line | Data |
6aaee015 |
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( %hash, force => 1 ) 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 (<$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 (<$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 (<$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; |