File Coverage

blib/lib/Dpkg/Checksums.pm
Criterion Covered Total %
statement 109 122 89.3
branch 25 44 56.8
condition 18 43 41.8
subroutine 21 22 95.4
pod 16 16 100.0
total 189 247 76.5


line stmt bran cond sub pod time code
1             # Copyright © 2008 Frank Lichtenheld
2             # Copyright © 2008, 2012-2015 Guillem Jover
3             # Copyright © 2010 Raphaël Hertzog
4             #
5             # This program is free software; you can redistribute it and/or modify
6             # it under the terms of the GNU General Public License as published by
7             # the Free Software Foundation; either version 2 of the License, or
8             # (at your option) any later version.
9             #
10             # This program is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13             # GNU General Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License
16             # along with this program. If not, see .
17              
18             package Dpkg::Checksums;
19              
20 2     2   910 use strict;
  2         4  
  2         59  
21 2     2   10 use warnings;
  2         4  
  2         106  
22              
23             our $VERSION = '1.04';
24             our @EXPORT = qw(
25             checksums_is_supported
26             checksums_get_list
27             checksums_get_property
28             );
29              
30 2     2   11 use Exporter qw(import);
  2         3  
  2         52  
31 2     2   1243 use Digest;
  2         1097  
  2         62  
32              
33 2     2   426 use Dpkg::Gettext;
  2         5  
  2         125  
34 2     2   418 use Dpkg::ErrorHandling;
  2         5  
  2         3588  
35              
36             =encoding utf8
37              
38             =head1 NAME
39              
40             Dpkg::Checksums - generate and manipulate file checksums
41              
42             =head1 DESCRIPTION
43              
44             This module provides a class that can generate and manipulate
45             various file checksums as well as some methods to query information
46             about supported checksums.
47              
48             =head1 FUNCTIONS
49              
50             =over 4
51              
52             =cut
53              
54             my $CHECKSUMS = {
55             md5 => {
56             name => 'MD5',
57             regex => qr/[0-9a-f]{32}/,
58             strong => 0,
59             },
60             sha1 => {
61             name => 'SHA-1',
62             regex => qr/[0-9a-f]{40}/,
63             strong => 0,
64             },
65             sha256 => {
66             name => 'SHA-256',
67             regex => qr/[0-9a-f]{64}/,
68             strong => 1,
69             },
70             };
71              
72             =item @list = checksums_get_list()
73              
74             Returns the list of supported checksums algorithms.
75              
76             =cut
77              
78             sub checksums_get_list() {
79 6     6 1 93 my @list = sort keys %{$CHECKSUMS};
  6         32  
80 6         22 return @list;
81             }
82              
83             =item $bool = checksums_is_supported($alg)
84              
85             Returns a boolean indicating whether the given checksum algorithm is
86             supported. The checksum algorithm is case-insensitive.
87              
88             =cut
89              
90             sub checksums_is_supported($) {
91 21     21 1 2169 my $alg = shift;
92 21         84 return exists $CHECKSUMS->{lc($alg)};
93             }
94              
95             =item $value = checksums_get_property($alg, $property)
96              
97             Returns the requested property of the checksum algorithm. Returns undef if
98             either the property or the checksum algorithm doesn't exist. Valid
99             properties currently include "name" (returns the name of the digest
100             algorithm), "regex" for the regular expression describing the common
101             string representation of the checksum, and "strong" for a boolean describing
102             whether the checksum algorithm is considered cryptographically strong.
103              
104             =cut
105              
106             sub checksums_get_property($$) {
107 15     15 1 40 my ($alg, $property) = @_;
108              
109 15 50       36 return unless checksums_is_supported($alg);
110 15         70 return $CHECKSUMS->{lc($alg)}{$property};
111             }
112              
113             =back
114              
115             =head1 METHODS
116              
117             =over 4
118              
119             =item $ck = Dpkg::Checksums->new()
120              
121             Create a new Dpkg::Checksums object. This object is able to store
122             the checksums of several files to later export them or verify them.
123              
124             =cut
125              
126             sub new {
127 1     1 1 420 my ($this, %opts) = @_;
128 1   33     12 my $class = ref($this) || $this;
129              
130 1         3 my $self = {};
131 1         3 bless $self, $class;
132 1         5 $self->reset();
133              
134 1         3 return $self;
135             }
136              
137             =item $ck->reset()
138              
139             Forget about all checksums stored. The object is again in the same state
140             as if it was newly created.
141              
142             =cut
143              
144             sub reset {
145 1     1 1 2 my $self = shift;
146              
147 1         9 $self->{files} = [];
148 1         4 $self->{checksums} = {};
149 1         2 $self->{size} = {};
150             }
151              
152             =item $ck->add_from_file($filename, %opts)
153              
154             Add or verify checksums information for the file $filename. The file must
155             exists for the call to succeed. If you don't want the given filename to
156             appear when you later export the checksums you might want to set the "key"
157             option with the public name that you want to use. Also if you don't want
158             to generate all the checksums, you can pass an array reference of the
159             wanted checksums in the "checksums" option.
160              
161             It the object already contains checksums information associated the
162             filename (or key), it will error out if the newly computed information
163             does not match what's stored, and the caller did not request that it be
164             updated with the boolean "update" option.
165              
166             =cut
167              
168             sub add_from_file {
169 3     3 1 20 my ($self, $file, %opts) = @_;
170 3 50       10 my $key = exists $opts{key} ? $opts{key} : $file;
171 3         4 my @alg;
172 3 50       8 if (exists $opts{checksums}) {
173 0         0 push @alg, map { lc } @{$opts{checksums}};
  0         0  
  0         0  
174             } else {
175 3         7 push @alg, checksums_get_list();
176             }
177              
178 3 50       12 push @{$self->{files}}, $key unless exists $self->{size}{$key};
  3         8  
179 3 50       87 (my @s = stat($file)) or syserr(g_('cannot fstat file %s'), $file);
180 3 50 33     22 if (not $opts{update} and exists $self->{size}{$key} and
      33        
181             $self->{size}{$key} != $s[7]) {
182             error(g_('file %s has size %u instead of expected %u'),
183 0         0 $file, $s[7], $self->{size}{$key});
184             }
185 3         8 $self->{size}{$key} = $s[7];
186              
187 3         7 foreach my $alg (@alg) {
188 9         52 my $digest = Digest->new($CHECKSUMS->{$alg}{name});
189 9 50       4649 open my $fh, '<', $file or syserr(g_('cannot open file %s'), $file);
190 9         110 $digest->addfile($fh);
191 9         256 close $fh;
192              
193 9         77 my $newsum = $digest->hexdigest;
194 9 50 33     56 if (not $opts{update} and exists $self->{checksums}{$key}{$alg} and
      33        
195             $self->{checksums}{$key}{$alg} ne $newsum) {
196             error(g_('file %s has checksum %s instead of expected %s (algorithm %s)'),
197 0         0 $file, $newsum, $self->{checksums}{$key}{$alg}, $alg);
198             }
199 9         70 $self->{checksums}{$key}{$alg} = $newsum;
200             }
201             }
202              
203             =item $ck->add_from_string($alg, $value, %opts)
204              
205             Add checksums of type $alg that are stored in the $value variable.
206             $value can be multi-lines, each line should be a space separated list
207             of checksum, file size and filename. Leading or trailing spaces are
208             not allowed.
209              
210             It the object already contains checksums information associated to the
211             filenames, it will error out if the newly read information does not match
212             what's stored, and the caller did not request that it be updated with
213             the boolean "update" option.
214              
215             =cut
216              
217             sub add_from_string {
218 6     6 1 2046 my ($self, $alg, $fieldtext, %opts) = @_;
219 6         15 $alg = lc($alg);
220 6         21 my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/;
221 6         15 my $regex = checksums_get_property($alg, 'regex');
222 6         11 my $checksums = $self->{checksums};
223              
224 6         40 for my $checksum (split /\n */, $fieldtext) {
225 18 100       41 next if $checksum eq '';
226 12 50       334 unless ($checksum =~ m/^($regex)\s+(\d+)\s+($rx_fname)$/) {
227 0         0 error(g_('invalid line in %s checksums string: %s'),
228             $alg, $checksum);
229             }
230 12         49 my ($sum, $size, $file) = ($1, $2, $3);
231 12 50 66     83 if (not $opts{update} and exists($checksums->{$file}{$alg})
      66        
232             and $checksums->{$file}{$alg} ne $sum) {
233             error(g_("conflicting checksums '%s' and '%s' for file '%s'"),
234 0         0 $checksums->{$file}{$alg}, $sum, $file);
235             }
236 12 50 66     62 if (not $opts{update} and exists $self->{size}{$file}
      66        
237             and $self->{size}{$file} != $size) {
238             error(g_("conflicting file sizes '%u' and '%u' for file '%s'"),
239 0         0 $self->{size}{$file}, $size, $file);
240             }
241 12 100       25 push @{$self->{files}}, $file unless exists $self->{size}{$file};
  1         4  
242 12         22 $checksums->{$file}{$alg} = $sum;
243 12         78 $self->{size}{$file} = $size;
244             }
245             }
246              
247             =item $ck->add_from_control($control, %opts)
248              
249             Read checksums from Checksums-* fields stored in the Dpkg::Control object
250             $control. It uses $self->add_from_string() on the field values to do the
251             actual work.
252              
253             If the option "use_files_for_md5" evaluates to true, then the "Files"
254             field is used in place of the "Checksums-Md5" field. By default the option
255             is false.
256              
257             =cut
258              
259             sub add_from_control {
260 1     1 1 9 my ($self, $control, %opts) = @_;
261 1   50     7 $opts{use_files_for_md5} //= 0;
262 1         5 foreach my $alg (checksums_get_list()) {
263 3         10 my $key = "Checksums-$alg";
264 3 50 33     8 $key = 'Files' if ($opts{use_files_for_md5} and $alg eq 'md5');
265 3 50       11 if (exists $control->{$key}) {
266 3         12 $self->add_from_string($alg, $control->{$key}, %opts);
267             }
268             }
269             }
270              
271             =item @files = $ck->get_files()
272              
273             Return the list of files whose checksums are stored in the object.
274              
275             =cut
276              
277             sub get_files {
278 14     14 1 1384 my $self = shift;
279 14         22 return @{$self->{files}};
  14         44  
280             }
281              
282             =item $bool = $ck->has_file($file)
283              
284             Return true if we have checksums for the given file. Returns false
285             otherwise.
286              
287             =cut
288              
289             sub has_file {
290 12     12 1 6866 my ($self, $file) = @_;
291 12         59 return exists $self->{size}{$file};
292             }
293              
294             =item $ck->remove_file($file)
295              
296             Remove all checksums of the given file.
297              
298             =cut
299              
300             sub remove_file {
301 1     1 1 4 my ($self, $file) = @_;
302 1 50       3 return unless $self->has_file($file);
303 1         4 delete $self->{checksums}{$file};
304 1         5 delete $self->{size}{$file};
305 1         3 @{$self->{files}} = grep { $_ ne $file } $self->get_files();
  1         4  
  3         8  
306             }
307              
308             =item $checksum = $ck->get_checksum($file, $alg)
309              
310             Return the checksum of type $alg for the requested $file. This will not
311             compute the checksum but only return the checksum stored in the object, if
312             any.
313              
314             If $alg is not defined, it returns a reference to a hash: keys are
315             the checksum algorithms and values are the checksums themselves. The
316             hash returned must not be modified, it's internal to the object.
317              
318             =cut
319              
320             sub get_checksum {
321 36     36 1 83 my ($self, $file, $alg) = @_;
322 36 100       112 $alg = lc($alg) if defined $alg;
323 36 50       82 if (exists $self->{checksums}{$file}) {
324 36 100       99 return $self->{checksums}{$file} unless defined $alg;
325 27         69 return $self->{checksums}{$file}{$alg};
326             }
327 0         0 return;
328             }
329              
330             =item $size = $ck->get_size($file)
331              
332             Return the size of the requested file if it's available in the object.
333              
334             =cut
335              
336             sub get_size {
337 36     36 1 60 my ($self, $file) = @_;
338 36         100 return $self->{size}{$file};
339             }
340              
341             =item $bool = $ck->has_strong_checksums($file)
342              
343             Return a boolean on whether the file has a strong checksum.
344              
345             =cut
346              
347             sub has_strong_checksums {
348 0     0 1 0 my ($self, $file) = @_;
349              
350 0         0 foreach my $alg (checksums_get_list()) {
351 0 0 0     0 return 1 if defined $self->get_checksum($file, $alg) and
352             checksums_get_property($alg, 'strong');
353             }
354              
355 0         0 return 0;
356             }
357              
358             =item $ck->export_to_string($alg, %opts)
359              
360             Return a multi-line string containing the checksums of type $alg. The
361             string can be stored as-is in a Checksum-* field of a Dpkg::Control
362             object.
363              
364             =cut
365              
366             sub export_to_string {
367 9     9 1 1488 my ($self, $alg, %opts) = @_;
368 9         17 my $res = '';
369 9         21 foreach my $file ($self->get_files()) {
370 27         49 my $sum = $self->get_checksum($file, $alg);
371 27         47 my $size = $self->get_size($file);
372 27 50 33     80 next unless defined $sum and defined $size;
373 27         83 $res .= "\n$sum $size $file";
374             }
375 9         31 return $res;
376             }
377              
378             =item $ck->export_to_control($control, %opts)
379              
380             Export the checksums in the Checksums-* fields of the Dpkg::Control
381             $control object.
382              
383             =cut
384              
385             sub export_to_control {
386 1     1 1 2 my ($self, $control, %opts) = @_;
387 1   50     8 $opts{use_files_for_md5} //= 0;
388 1         3 foreach my $alg (checksums_get_list()) {
389 3         6 my $key = "Checksums-$alg";
390 3 50 33     10 $key = 'Files' if ($opts{use_files_for_md5} and $alg eq 'md5');
391 3         8 $control->{$key} = $self->export_to_string($alg, %opts);
392             }
393             }
394              
395             =back
396              
397             =head1 CHANGES
398              
399             =head2 Version 1.04 (dpkg 1.20.0)
400              
401             Remove warning: For obsolete property 'program'.
402              
403             =head2 Version 1.03 (dpkg 1.18.5)
404              
405             New property: Add new 'strong' property.
406              
407             New member: $ck->has_strong_checksums().
408              
409             =head2 Version 1.02 (dpkg 1.18.0)
410              
411             Obsolete property: Getting the 'program' checksum property will warn and
412             return undef, the Digest module is used internally now.
413              
414             New property: Add new 'name' property with the name of the Digest algorithm
415             to use.
416              
417             =head2 Version 1.01 (dpkg 1.17.6)
418              
419             New argument: Accept an options argument in $ck->export_to_string().
420              
421             New option: Accept new option 'update' in $ck->add_from_file() and
422             $ck->add_from_control().
423              
424             =head2 Version 1.00 (dpkg 1.15.6)
425              
426             Mark the module as public.
427              
428             =cut
429              
430             1;