Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | # Copyright © 2008 Frank Lichtenheld <djpig@debian.org> |
2 | # Copyright © 2008, 2012-2015 Guillem Jover <guillem@debian.org> | |
3 | # Copyright © 2010 Raphaël Hertzog <hertzog@debian.org> | |
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 <https://www.gnu.org/licenses/>. | |
17 | ||
18 | package Dpkg::Checksums; | |
19 | ||
20 | use strict; | |
21 | use warnings; | |
22 | ||
23 | our $VERSION = '1.03'; | |
24 | our @EXPORT = qw( | |
25 | checksums_is_supported | |
26 | checksums_get_list | |
27 | checksums_get_property | |
28 | ); | |
29 | ||
30 | use Exporter qw(import); | |
31 | use Digest; | |
32 | ||
33 | use Dpkg::Gettext; | |
34 | use Dpkg::ErrorHandling; | |
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 an object 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 | my @list = sort keys %{$CHECKSUMS}; | |
80 | 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 | my $alg = shift; | |
92 | 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 | my ($alg, $property) = @_; | |
108 | ||
109 | if ($property eq 'program') { | |
110 | warnings::warnif('deprecated', 'obsolete checksums program property'); | |
111 | } | |
112 | ||
113 | return unless checksums_is_supported($alg); | |
114 | return $CHECKSUMS->{lc($alg)}{$property}; | |
115 | } | |
116 | ||
117 | =back | |
118 | ||
119 | =head1 METHODS | |
120 | ||
121 | =over 4 | |
122 | ||
123 | =item $ck = Dpkg::Checksums->new() | |
124 | ||
125 | Create a new Dpkg::Checksums object. This object is able to store | |
126 | the checksums of several files to later export them or verify them. | |
127 | ||
128 | =cut | |
129 | ||
130 | sub new { | |
131 | my ($this, %opts) = @_; | |
132 | my $class = ref($this) || $this; | |
133 | ||
134 | my $self = {}; | |
135 | bless $self, $class; | |
136 | $self->reset(); | |
137 | ||
138 | return $self; | |
139 | } | |
140 | ||
141 | =item $ck->reset() | |
142 | ||
143 | Forget about all checksums stored. The object is again in the same state | |
144 | as if it was newly created. | |
145 | ||
146 | =cut | |
147 | ||
148 | sub reset { | |
149 | my $self = shift; | |
150 | ||
151 | $self->{files} = []; | |
152 | $self->{checksums} = {}; | |
153 | $self->{size} = {}; | |
154 | } | |
155 | ||
156 | =item $ck->add_from_file($filename, %opts) | |
157 | ||
158 | Add or verify checksums information for the file $filename. The file must | |
159 | exists for the call to succeed. If you don't want the given filename to | |
160 | appear when you later export the checksums you might want to set the "key" | |
161 | option with the public name that you want to use. Also if you don't want | |
162 | to generate all the checksums, you can pass an array reference of the | |
163 | wanted checksums in the "checksums" option. | |
164 | ||
165 | It the object already contains checksums information associated the | |
166 | filename (or key), it will error out if the newly computed information | |
167 | does not match what's stored, and the caller did not request that it be | |
168 | updated with the boolean "update" option. | |
169 | ||
170 | =cut | |
171 | ||
172 | sub add_from_file { | |
173 | my ($self, $file, %opts) = @_; | |
174 | my $key = exists $opts{key} ? $opts{key} : $file; | |
175 | my @alg; | |
176 | if (exists $opts{checksums}) { | |
177 | push @alg, map { lc } @{$opts{checksums}}; | |
178 | } else { | |
179 | push @alg, checksums_get_list(); | |
180 | } | |
181 | ||
182 | push @{$self->{files}}, $key unless exists $self->{size}{$key}; | |
183 | (my @s = stat($file)) or syserr(g_('cannot fstat file %s'), $file); | |
184 | if (not $opts{update} and exists $self->{size}{$key} and | |
185 | $self->{size}{$key} != $s[7]) { | |
186 | error(g_('file %s has size %u instead of expected %u'), | |
187 | $file, $s[7], $self->{size}{$key}); | |
188 | } | |
189 | $self->{size}{$key} = $s[7]; | |
190 | ||
191 | foreach my $alg (@alg) { | |
192 | my $digest = Digest->new($CHECKSUMS->{$alg}{name}); | |
193 | open my $fh, '<', $file or syserr(g_('cannot open file %s'), $file); | |
194 | $digest->addfile($fh); | |
195 | close $fh; | |
196 | ||
197 | my $newsum = $digest->hexdigest; | |
198 | if (not $opts{update} and exists $self->{checksums}{$key}{$alg} and | |
199 | $self->{checksums}{$key}{$alg} ne $newsum) { | |
200 | error(g_('file %s has checksum %s instead of expected %s (algorithm %s)'), | |
201 | $file, $newsum, $self->{checksums}{$key}{$alg}, $alg); | |
202 | } | |
203 | $self->{checksums}{$key}{$alg} = $newsum; | |
204 | } | |
205 | } | |
206 | ||
207 | =item $ck->add_from_string($alg, $value, %opts) | |
208 | ||
209 | Add checksums of type $alg that are stored in the $value variable. | |
210 | $value can be multi-lines, each line should be a space separated list | |
211 | of checksum, file size and filename. Leading or trailing spaces are | |
212 | not allowed. | |
213 | ||
214 | It the object already contains checksums information associated to the | |
215 | filenames, it will error out if the newly read information does not match | |
216 | what's stored, and the caller did not request that it be updated with | |
217 | the boolean "update" option. | |
218 | ||
219 | =cut | |
220 | ||
221 | sub add_from_string { | |
222 | my ($self, $alg, $fieldtext, %opts) = @_; | |
223 | $alg = lc($alg); | |
224 | my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/; | |
225 | my $regex = checksums_get_property($alg, 'regex'); | |
226 | my $checksums = $self->{checksums}; | |
227 | ||
228 | for my $checksum (split /\n */, $fieldtext) { | |
229 | next if $checksum eq ''; | |
230 | unless ($checksum =~ m/^($regex)\s+(\d+)\s+($rx_fname)$/) { | |
231 | error(g_('invalid line in %s checksums string: %s'), | |
232 | $alg, $checksum); | |
233 | } | |
234 | my ($sum, $size, $file) = ($1, $2, $3); | |
235 | if (not $opts{update} and exists($checksums->{$file}{$alg}) | |
236 | and $checksums->{$file}{$alg} ne $sum) { | |
237 | error(g_("conflicting checksums '%s' and '%s' for file '%s'"), | |
238 | $checksums->{$file}{$alg}, $sum, $file); | |
239 | } | |
240 | if (not $opts{update} and exists $self->{size}{$file} | |
241 | and $self->{size}{$file} != $size) { | |
242 | error(g_("conflicting file sizes '%u' and '%u' for file '%s'"), | |
243 | $self->{size}{$file}, $size, $file); | |
244 | } | |
245 | push @{$self->{files}}, $file unless exists $self->{size}{$file}; | |
246 | $checksums->{$file}{$alg} = $sum; | |
247 | $self->{size}{$file} = $size; | |
248 | } | |
249 | } | |
250 | ||
251 | =item $ck->add_from_control($control, %opts) | |
252 | ||
253 | Read checksums from Checksums-* fields stored in the Dpkg::Control object | |
254 | $control. It uses $self->add_from_string() on the field values to do the | |
255 | actual work. | |
256 | ||
257 | If the option "use_files_for_md5" evaluates to true, then the "Files" | |
258 | field is used in place of the "Checksums-Md5" field. By default the option | |
259 | is false. | |
260 | ||
261 | =cut | |
262 | ||
263 | sub add_from_control { | |
264 | my ($self, $control, %opts) = @_; | |
265 | $opts{use_files_for_md5} //= 0; | |
266 | foreach my $alg (checksums_get_list()) { | |
267 | my $key = "Checksums-$alg"; | |
268 | $key = 'Files' if ($opts{use_files_for_md5} and $alg eq 'md5'); | |
269 | if (exists $control->{$key}) { | |
270 | $self->add_from_string($alg, $control->{$key}, %opts); | |
271 | } | |
272 | } | |
273 | } | |
274 | ||
275 | =item @files = $ck->get_files() | |
276 | ||
277 | Return the list of files whose checksums are stored in the object. | |
278 | ||
279 | =cut | |
280 | ||
281 | sub get_files { | |
282 | my $self = shift; | |
283 | return @{$self->{files}}; | |
284 | } | |
285 | ||
286 | =item $bool = $ck->has_file($file) | |
287 | ||
288 | Return true if we have checksums for the given file. Returns false | |
289 | otherwise. | |
290 | ||
291 | =cut | |
292 | ||
293 | sub has_file { | |
294 | my ($self, $file) = @_; | |
295 | return exists $self->{size}{$file}; | |
296 | } | |
297 | ||
298 | =item $ck->remove_file($file) | |
299 | ||
300 | Remove all checksums of the given file. | |
301 | ||
302 | =cut | |
303 | ||
304 | sub remove_file { | |
305 | my ($self, $file) = @_; | |
306 | return unless $self->has_file($file); | |
307 | delete $self->{checksums}{$file}; | |
308 | delete $self->{size}{$file}; | |
309 | @{$self->{files}} = grep { $_ ne $file } $self->get_files(); | |
310 | } | |
311 | ||
312 | =item $checksum = $ck->get_checksum($file, $alg) | |
313 | ||
314 | Return the checksum of type $alg for the requested $file. This will not | |
315 | compute the checksum but only return the checksum stored in the object, if | |
316 | any. | |
317 | ||
318 | If $alg is not defined, it returns a reference to a hash: keys are | |
319 | the checksum algorithms and values are the checksums themselves. The | |
320 | hash returned must not be modified, it's internal to the object. | |
321 | ||
322 | =cut | |
323 | ||
324 | sub get_checksum { | |
325 | my ($self, $file, $alg) = @_; | |
326 | $alg = lc($alg) if defined $alg; | |
327 | if (exists $self->{checksums}{$file}) { | |
328 | return $self->{checksums}{$file} unless defined $alg; | |
329 | return $self->{checksums}{$file}{$alg}; | |
330 | } | |
331 | return; | |
332 | } | |
333 | ||
334 | =item $size = $ck->get_size($file) | |
335 | ||
336 | Return the size of the requested file if it's available in the object. | |
337 | ||
338 | =cut | |
339 | ||
340 | sub get_size { | |
341 | my ($self, $file) = @_; | |
342 | return $self->{size}{$file}; | |
343 | } | |
344 | ||
345 | =item $bool = $ck->has_strong_checksums($file) | |
346 | ||
347 | Return a boolean on whether the file has a strong checksum. | |
348 | ||
349 | =cut | |
350 | ||
351 | sub has_strong_checksums { | |
352 | my ($self, $file) = @_; | |
353 | ||
354 | foreach my $alg (checksums_get_list()) { | |
355 | return 1 if defined $self->get_checksum($file, $alg) and | |
356 | checksums_get_property($alg, 'strong'); | |
357 | } | |
358 | ||
359 | return 0; | |
360 | } | |
361 | ||
362 | =item $ck->export_to_string($alg, %opts) | |
363 | ||
364 | Return a multi-line string containing the checksums of type $alg. The | |
365 | string can be stored as-is in a Checksum-* field of a Dpkg::Control | |
366 | object. | |
367 | ||
368 | =cut | |
369 | ||
370 | sub export_to_string { | |
371 | my ($self, $alg, %opts) = @_; | |
372 | my $res = ''; | |
373 | foreach my $file ($self->get_files()) { | |
374 | my $sum = $self->get_checksum($file, $alg); | |
375 | my $size = $self->get_size($file); | |
376 | next unless defined $sum and defined $size; | |
377 | $res .= "\n$sum $size $file"; | |
378 | } | |
379 | return $res; | |
380 | } | |
381 | ||
382 | =item $ck->export_to_control($control, %opts) | |
383 | ||
384 | Export the checksums in the Checksums-* fields of the Dpkg::Control | |
385 | $control object. | |
386 | ||
387 | =cut | |
388 | ||
389 | sub export_to_control { | |
390 | my ($self, $control, %opts) = @_; | |
391 | $opts{use_files_for_md5} //= 0; | |
392 | foreach my $alg (checksums_get_list()) { | |
393 | my $key = "Checksums-$alg"; | |
394 | $key = 'Files' if ($opts{use_files_for_md5} and $alg eq 'md5'); | |
395 | $control->{$key} = $self->export_to_string($alg, %opts); | |
396 | } | |
397 | } | |
398 | ||
399 | =back | |
400 | ||
401 | =head1 CHANGES | |
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; |