Commit | Line | Data |
---|---|---|
6aaee015 RGS |
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) | |
28aafdbe | 78 | unless can_load( modules => { 'Digest::SHA' => '0.0' } ); |
6aaee015 RGS |
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 | ||
28aafdbe | 106 | my $sha = $href->{ $self->package }->{'sha256'}; |
6aaee015 | 107 | |
28aafdbe CBW |
108 | unless( defined $sha ) { |
109 | msg(loc("No 'sha256' checksum known for '%1'",$self->package),$verbose); | |
6aaee015 RGS |
110 | |
111 | return $self->status->checksum_ok(1); | |
112 | } | |
113 | ||
28aafdbe | 114 | $self->status->checksum_value($sha); |
6aaee015 RGS |
115 | |
116 | ||
117 | my $fh = FileHandle->new( $self->status->fetch ) or return; | |
118 | binmode $fh; | |
119 | ||
28aafdbe | 120 | my $ctx = Digest::SHA->new(256); |
6aaee015 RGS |
121 | $ctx->addfile( $fh ); |
122 | ||
28aafdbe CBW |
123 | my $hexdigest = $ctx->hexdigest; |
124 | my $flag = $hexdigest eq $sha; | |
6aaee015 RGS |
125 | $flag |
126 | ? msg(loc("Checksum matches for '%1'", $self->package),$verbose) | |
127 | : error(loc("Checksum does not match for '%1': " . | |
28aafdbe CBW |
128 | "SHA256 is '%2' but should be '%3'", |
129 | $self->package, $hexdigest, $sha),$verbose); | |
6aaee015 RGS |
130 | |
131 | ||
132 | return $self->status->checksum_ok(1) if $flag; | |
133 | return $self->status->checksum_ok(0); | |
134 | } | |
135 | ||
136 | ||
137 | ### fetches the module objects checksum file ### | |
138 | sub _get_checksums_file { | |
139 | my $self = shift; | |
140 | my %hash = @_; | |
141 | ||
142 | my $clone = $self->clone; | |
143 | $clone->package( CHECKSUMS ); | |
144 | ||
4443dd53 | 145 | my $file = $clone->fetch( ttl => 3600, %hash ) or return; |
6aaee015 RGS |
146 | |
147 | return $file; | |
148 | } | |
149 | ||
150 | sub _parse_checksums_file { | |
151 | my $self = shift; | |
152 | my %hash = @_; | |
153 | ||
154 | my $file; | |
155 | my $tmpl = { | |
156 | file => { required => 1, allow => FILE_READABLE, store => \$file }, | |
157 | }; | |
158 | my $args = check( $tmpl, \%hash ); | |
159 | ||
160 | my $fh = OPEN_FILE->( $file ) or return; | |
161 | ||
162 | ### loop over the header, there might be a pgp signature ### | |
163 | my $signed; | |
4443dd53 | 164 | while (local $_ = <$fh>) { |
6aaee015 RGS |
165 | last if /^\$cksum = \{\s*$/; # skip till this line |
166 | my $header = PGP_HEADER; # but be tolerant of whitespace | |
167 | $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks | |
168 | } | |
169 | ||
170 | ### read the filehandle, parse it rather than eval it, even though it | |
171 | ### *should* be valid perl code | |
172 | my $dist; | |
173 | my $cksum = {}; | |
4443dd53 | 174 | while (local $_ = <$fh>) { |
6aaee015 RGS |
175 | |
176 | if (/^\s*'([^']+)' => \{\s*$/) { | |
177 | $dist = $1; | |
178 | ||
179 | } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) { | |
180 | $cksum->{$dist}{$1} = $2; | |
181 | ||
182 | } elsif (/^\s*}[,;]?\s*$/) { | |
183 | undef $dist; | |
184 | ||
185 | } elsif (/^__END__\s*$/) { | |
186 | last; | |
187 | ||
188 | } else { | |
189 | error( loc("Malformed %1 line: %2", CHECKSUMS, $_) ); | |
190 | } | |
191 | } | |
192 | ||
193 | return $cksum; | |
194 | } | |
195 | ||
196 | sub _check_signature_for_checksum_file { | |
197 | my $self = shift; | |
198 | ||
199 | my $conf = $self->parent->configure_object; | |
200 | my %hash = @_; | |
201 | ||
202 | ### you don't want to check signatures, | |
203 | ### so let's just return true; | |
204 | return 1 unless $conf->get_conf('signature'); | |
205 | ||
206 | my($force,$file,$verbose); | |
207 | my $tmpl = { | |
208 | file => { required => 1, allow => FILE_READABLE, store => \$file }, | |
209 | force => { default => $conf->get_conf('force'), store => \$force }, | |
210 | verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, | |
211 | }; | |
212 | ||
213 | my $args = check( $tmpl, \%hash ) or return; | |
214 | ||
215 | my $fh = OPEN_FILE->($file) or return; | |
216 | ||
217 | my $signed; | |
4443dd53 | 218 | while (local $_ = <$fh>) { |
6aaee015 RGS |
219 | my $header = PGP_HEADER; |
220 | $signed = 1 if /^$header$/; | |
221 | } | |
222 | ||
223 | if ( !$signed ) { | |
224 | msg(loc("No signature found in %1 file '%2'", | |
225 | CHECKSUMS, $file), $verbose); | |
226 | ||
227 | return 1 unless $force; | |
228 | ||
229 | error( loc( "%1 file '%2' is not signed -- aborting", | |
230 | CHECKSUMS, $file ) ); | |
231 | return; | |
232 | ||
233 | } | |
234 | ||
235 | if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) { | |
236 | # local $Module::Signature::SIGNATURE = $file; | |
237 | # ... check signatures ... | |
238 | } | |
239 | ||
240 | return 1; | |
241 | } | |
242 | ||
243 | ||
244 | ||
245 | # Local variables: | |
246 | # c-indentation-style: bsd | |
247 | # c-basic-offset: 4 | |
248 | # indent-tabs-mode: nil | |
249 | # End: | |
250 | # vim: expandtab shiftwidth=4: | |
251 | ||
252 | 1; |