scripts/Dpkg/Checksums.pm

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