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