1package CPANPLUS::Module::Checksums;
2
3use strict;
4use vars qw[@ISA $VERSION];
5
6use CPANPLUS::Error;
7use CPANPLUS::Internals::Constants;
8
9use FileHandle;
10
11use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
12use Params::Check               qw[check];
13use Module::Load::Conditional   qw[can_load];
14
15$Params::Check::VERBOSE = 1;
16
17@ISA = qw[ CPANPLUS::Module::Signature ];
18$VERSION = "0.9912";
19
20=head1 NAME
21
22CPANPLUS::Module::Checksums - checking the checksum of a distribution
23
24=head1 SYNOPSIS
25
26    $file   = $modobj->checksums;
27    $bool   = $mobobj->_validate_checksum;
28
29=head1 DESCRIPTION
30
31This is a class that provides functions for checking the checksum
32of a distribution. Should not be loaded directly, but used via the
33interface provided via C<CPANPLUS::Module>.
34
35=head1 METHODS
36
37=head2 $mod->checksums
38
39Fetches the checksums file for this module object.
40For the options it can take, see C<CPANPLUS::Module::fetch()>.
41
42Returns the location of the checksums file on success and false
43on error.
44
45The location of the checksums file is also stored as
46
47    $mod->status->checksums
48
49=cut
50
51sub 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
63sub _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::SHA' => '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 $sha = $href->{ $self->package }->{'sha256'};
107
108    unless( defined $sha ) {
109        msg(loc("No 'sha256' checksum known for '%1'",$self->package),$verbose);
110
111        return $self->status->checksum_ok(1);
112    }
113
114    $self->status->checksum_value($sha);
115
116
117    my $fh = FileHandle->new( $self->status->fetch ) or return;
118    binmode $fh;
119
120    my $ctx = Digest::SHA->new(256);
121    $ctx->addfile( $fh );
122
123    my $hexdigest = $ctx->hexdigest;
124    my $flag = $hexdigest eq $sha;
125    $flag
126        ? msg(loc("Checksum matches for '%1'", $self->package),$verbose)
127        : error(loc("Checksum does not match for '%1': " .
128                    "SHA256 is '%2' but should be '%3'",
129                    $self->package, $hexdigest, $sha),$verbose);
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 ###
138sub _get_checksums_file {
139    my $self = shift;
140    my %hash = @_;
141
142    my $clone = $self->clone;
143    $clone->package( CHECKSUMS );
144
145    # If the user specified a fetchdir, then every CHECKSUMS file will always
146    # be stored there, not in an author-specific subdir.  Thus, in this case,
147    # we need to always re-fetch the CHECKSUMS file and hence need to set the
148    # TTL to something small.
149    my $have_fetchdir =
150        $self->parent->configure_object->get_conf('fetchdir') ne '';
151    my $ttl = $have_fetchdir ? 0.001 : 3600;
152    my $file = $clone->fetch( ttl => $ttl, %hash ) or return;
153
154    return $file;
155}
156
157sub _parse_checksums_file {
158    my $self = shift;
159    my %hash = @_;
160
161    my $file;
162    my $tmpl = {
163        file    => { required => 1, allow => FILE_READABLE, store => \$file },
164    };
165    my $args = check( $tmpl, \%hash );
166
167    my $fh = OPEN_FILE->( $file ) or return;
168
169    ### loop over the header, there might be a pgp signature ###
170    my $signed;
171    while (local $_ = <$fh>) {
172        last if /^\$cksum = \{\s*$/;    # skip till this line
173        my $header = PGP_HEADER;        # but be tolerant of whitespace
174        $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks
175   }
176
177    ### read the filehandle, parse it rather than eval it, even though it
178    ### *should* be valid perl code
179    my $dist;
180    my $cksum = {};
181    while (local $_ = <$fh>) {
182
183        if (/^\s*'([^']+)' => \{\s*$/) {
184            $dist = $1;
185
186        } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) {
187            $cksum->{$dist}{$1} = $2;
188
189        } elsif (/^\s*}[,;]?\s*$/) {
190            undef $dist;
191
192        } elsif (/^__END__\s*$/) {
193            last;
194
195        } else {
196            error( loc("Malformed %1 line: %2", CHECKSUMS, $_) );
197        }
198    }
199
200    return $cksum;
201}
202
203sub _check_signature_for_checksum_file {
204    my $self = shift;
205
206    my $conf = $self->parent->configure_object;
207    my %hash = @_;
208
209    ### you don't want to check signatures,
210    ### so let's just return true;
211    return 1 unless $conf->get_conf('signature');
212
213    my($force,$file,$verbose);
214    my $tmpl = {
215        file    => { required => 1, allow => FILE_READABLE, store => \$file },
216        force   => { default => $conf->get_conf('force'), store => \$force },
217        verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
218    };
219
220    my $args = check( $tmpl, \%hash ) or return;
221
222    my $fh = OPEN_FILE->($file) or return;
223
224    my $signed;
225    while (local $_ = <$fh>) {
226        my $header = PGP_HEADER;
227        $signed = 1 if /^$header$/;
228    }
229
230    if ( !$signed ) {
231        msg(loc("No signature found in %1 file '%2'",
232                CHECKSUMS, $file), $verbose);
233
234        return 1 unless $force;
235
236        error( loc( "%1 file '%2' is not signed -- aborting",
237                    CHECKSUMS, $file ) );
238        return;
239
240    }
241
242    if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) {
243        # local $Module::Signature::SIGNATURE = $file;
244        # ... check signatures ...
245    }
246
247    return 1;
248}
249
250
251
252# Local variables:
253# c-indentation-style: bsd
254# c-basic-offset: 4
255# indent-tabs-mode: nil
256# End:
257# vim: expandtab shiftwidth=4:
258
2591;
260