chiark - git - mdw - dpkg/blob - scripts/Dpkg/Source/Package.pm

   1 # Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org>
   2 # Copyright © 2008-2015 Guillem Jover <guillem@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::Source::Package;
  18
  19 =encoding utf8
  20
  21 =head1 NAME
  22
  23 Dpkg::Source::Package - manipulate Debian source packages
  24
  25 =head1 DESCRIPTION
  26
  27 This module provides an object that can manipulate Debian source
  28 packages. While it supports both the extraction and the creation
  29 of source packages, the only API that is officially supported
  30 is the one that supports the extraction of the source package.
  31
  32 =cut
  33
  34 use strict;
  35 use warnings;
  36
  37 our $VERSION = '1.02';
  38 our @EXPORT_OK = qw(
  39     get_default_diff_ignore_regex
  40     set_default_diff_ignore_regex
  41     get_default_tar_ignore_pattern
  42 );
  43
  44 use Exporter qw(import);
  45 use POSIX qw(:errno_h :sys_wait_h);
  46 use Carp;
  47 use File::Basename;
  48
  49 use Dpkg::Gettext;
  50 use Dpkg::ErrorHandling;
  51 use Dpkg::Control;
  52 use Dpkg::Checksums;
  53 use Dpkg::Version;
  54 use Dpkg::Compression;
  55 use Dpkg::Exit qw(run_exit_handlers);
  56 use Dpkg::Path qw(check_files_are_the_same find_command);
  57 use Dpkg::IPC;
  58 use Dpkg::Vendor qw(run_vendor_hook);
  59
  60 my $diff_ignore_default_regex = '
  61 # Ignore general backup files
  62 (?:^|/).*~$|
  63 # Ignore emacs recovery files
  64 (?:^|/)\.#.*$|
  65 # Ignore vi swap files
  66 (?:^|/)\..*\.sw.$|
  67 # Ignore baz-style junk files or directories
  68 (?:^|/),,.*(?:$|/.*$)|
  69 # File-names that should be ignored (never directories)
  70 (?:^|/)(?:DEADJOE|\.arch-inventory|\.(?:bzr|cvs|hg|git|mtn-)ignore)$|
  71 # File or directory names that should be ignored
  72 (?:^|/)(?:CVS|RCS|\.deps|\{arch\}|\.arch-ids|\.svn|
  73 \.hg(?:tags|sigs)?|_darcs|\.git(?:attributes|modules|review)?|
  74 \.mailmap|\.shelf|_MTN|\.be|\.bzr(?:\.backup|tags)?)(?:$|/.*$)
  75 ';
  76 # Take out comments and newlines
  77 $diff_ignore_default_regex =~ s/^#.*$//mg;
  78 $diff_ignore_default_regex =~ s/\n//sg;
  79
  80 # Public variables
  81 # XXX: Backwards compatibility, stop exporting on VERSION 2.00.
  82 ## no critic (Variables::ProhibitPackageVars)
  83 our $diff_ignore_default_regexp;
  84 *diff_ignore_default_regexp = \$diff_ignore_default_regex;
  85
  86 no warnings 'qw'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)
  87 our @tar_ignore_default_pattern = qw(
  88 *.a
  89 *.la
  90 *.o
  91 *.so
  92 .*.sw?
  93 */*~
  94 ,,*
  95 .[#~]*
  96 .arch-ids
  97 .arch-inventory
  98 .be
  99 .bzr
 100 .bzr.backup
 101 .bzr.tags
 102 .bzrignore
 103 .cvsignore
 104 .deps
 105 .git
 106 .gitattributes
 107 .gitignore
 108 .gitmodules
 109 .gitreview
 110 .hg
 111 .hgignore
 112 .hgsigs
 113 .hgtags
 114 .mailmap
 115 .mtn-ignore
 116 .shelf
 117 .svn
 118 CVS
 119 DEADJOE
 120 RCS
 121 _MTN
 122 _darcs
 123 {arch}
 124 );
 125 ## use critic
 126
 127 =head1 FUNCTIONS
 128
 129 =over 4
 130
 131 =item $string = get_default_diff_ignore_regex()
 132
 133 Returns the default diff ignore regex.
 134
 135 =cut
 136
 137 sub get_default_diff_ignore_regex {
 138     return $diff_ignore_default_regex;
 139 }
 140
 141 =item set_default_diff_ignore_regex($string)
 142
 143 Set a regex as the new default diff ignore regex.
 144
 145 =cut
 146
 147 sub set_default_diff_ignore_regex {
 148     my $regex = shift;
 149
 150     $diff_ignore_default_regex = $regex;
 151 }
 152
 153 =item @array = get_default_tar_ignore_pattern()
 154
 155 Returns the default tar ignore pattern, as an array.
 156
 157 =cut
 158
 159 sub get_default_tar_ignore_pattern {
 160     return @tar_ignore_default_pattern;
 161 }
 162
 163 =back
 164
 165 =head1 METHODS
 166
 167 =over 4
 168
 169 =item $p = Dpkg::Source::Package->new(filename => $dscfile, options => {})
 170
 171 Creates a new object corresponding to the source package described
 172 by the file $dscfile.
 173
 174 The options hash supports the following options:
 175
 176 =over 8
 177
 178 =item skip_debianization
 179
 180 If set to 1, do not apply Debian changes on the extracted source package.
 181
 182 =item skip_patches
 183
 184 If set to 1, do not apply Debian-specific patches. This options is
 185 specific for source packages using format "2.0" and "3.0 (quilt)".
 186
 187 =item require_valid_signature
 188
 189 If set to 1, the check_signature() method will be stricter and will error
 190 out if the signature can't be verified.
 191
 192 =item require_strong_checksums
 193
 194 If set to 1, the check_checksums() method will be stricter and will error
 195 out if there is no strong checksum.
 196
 197 =item copy_orig_tarballs
 198
 199 If set to 1, the extraction will copy the upstream tarballs next the
 200 target directory. This is useful if you want to be able to rebuild the
 201 source package after its extraction.
 202
 203 =back
 204
 205 =cut
 206
 207 # Object methods
 208 sub new {
 209     my ($this, %args) = @_;
 210     my $class = ref($this) || $this;
 211     my $self = {
 212         fields => Dpkg::Control->new(type => CTRL_PKG_SRC),
 213         options => {},
 214         checksums => Dpkg::Checksums->new(),
 215     };
 216     bless $self, $class;
 217     if (exists $args{options}) {
 218         $self->{options} = $args{options};
 219     }
 220     if (exists $args{filename}) {
 221         $self->initialize($args{filename});
 222         $self->init_options();
 223     }
 224     return $self;
 225 }
 226
 227 sub init_options {
 228     my $self = shift;
 229     # Use full ignore list by default
 230     # note: this function is not called by V1 packages
 231     $self->{options}{diff_ignore_regex} ||= $diff_ignore_default_regex;
 232     $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$';
 233     $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$';
 234     if (defined $self->{options}{tar_ignore}) {
 235         $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ]
 236             unless @{$self->{options}{tar_ignore}};
 237     } else {
 238         $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ];
 239     }
 240     push @{$self->{options}{tar_ignore}},
 241          'debian/source/local-options',
 242          'debian/source/local-patch-header',
 243          'debian/files',
 244          'debian/files.new';
 245     # Skip debianization while specific to some formats has an impact
 246     # on code common to all formats
 247     $self->{options}{skip_debianization} //= 0;
 248
 249     # Set default compressor for new formats.
 250     $self->{options}{compression} //= 'xz';
 251     $self->{options}{comp_level} //= compression_get_property($self->{options}{compression},
 252                                                               'default_level');
 253     $self->{options}{comp_ext} //= compression_get_property($self->{options}{compression},
 254                                                             'file_ext');
 255 }
 256
 257 sub initialize {
 258     my ($self, $filename) = @_;
 259     my ($fn, $dir) = fileparse($filename);
 260     error(g_('%s is not the name of a file'), $filename) unless $fn;
 261     $self->{basedir} = $dir || './';
 262     $self->{filename} = $fn;
 263
 264     # Read the fields
 265     my $fields = Dpkg::Control->new(type => CTRL_PKG_SRC);
 266     $fields->load($filename);
 267     $self->{fields} = $fields;
 268     $self->{is_signed} = $fields->get_option('is_pgp_signed');
 269
 270     foreach my $f (qw(Source Version Files)) {
 271         unless (defined($fields->{$f})) {
 272             error(g_('missing critical source control field %s'), $f);
 273         }
 274     }
 275
 276     $self->{checksums}->add_from_control($fields, use_files_for_md5 => 1);
 277
 278     $self->upgrade_object_type(0);
 279 }
 280
 281 sub upgrade_object_type {
 282     my ($self, $update_format) = @_;
 283     $update_format //= 1;
 284     $self->{fields}{'Format'} //= '1.0';
 285     my $format = $self->{fields}{'Format'};
 286
 287     if ($format =~ /^([\d\.]+)(?:\s+\((.*)\))?$/) {
 288         my ($version, $variant) = ($1, $2);
 289
 290         if (defined $variant and $variant ne lc $variant) {
 291             error(g_("source package format '%s' is not supported: %s"),
 292                   $format, g_('format variant must be in lowercase'));
 293         }
 294
 295         my $major = $version =~ s/\.[\d\.]+$//r;
 296         my $minor;
 297
 298         my $module = "Dpkg::Source::Package::V$major";
 299         $module .= '::' . ucfirst $variant if defined $variant;
 300         eval qq{
 301             pop \@INC if \$INC[-1] eq '.';
 302             require $module;
 303             \$minor = \$${module}::CURRENT_MINOR_VERSION;
 304         };
 305         $minor //= 0;
 306         if ($update_format) {
 307             $self->{fields}{'Format'} = "$major.$minor";
 308             $self->{fields}{'Format'} .= " ($variant)" if defined $variant;
 309         }
 310         if ($@) {
 311             error(g_("source package format '%s' is not supported: %s"),
 312                   $format, $@);
 313         }
 314         bless $self, $module;
 315     } else {
 316         error(g_("invalid Format field '%s'"), $format);
 317     }
 318 }
 319
 320 =item $p->get_filename()
 321
 322 Returns the filename of the DSC file.
 323
 324 =cut
 325
 326 sub get_filename {
 327     my $self = shift;
 328     return $self->{basedir} . $self->{filename};
 329 }
 330
 331 =item $p->get_files()
 332
 333 Returns the list of files referenced by the source package. The filenames
 334 usually do not have any path information.
 335
 336 =cut
 337
 338 sub get_files {
 339     my $self = shift;
 340     return $self->{checksums}->get_files();
 341 }
 342
 343 =item $p->check_checksums()
 344
 345 Verify the checksums embedded in the DSC file. It requires the presence of
 346 the other files constituting the source package. If any inconsistency is
 347 discovered, it immediately errors out. It will make sure at least one strong
 348 checksum is present.
 349
 350 If the object has been created with the "require_strong_checksums" option,
 351 then any problem will result in a fatal error.
 352
 353 =cut
 354
 355 sub check_checksums {
 356     my $self = shift;
 357     my $checksums = $self->{checksums};
 358     my $warn_on_weak = 0;
 359
 360     # add_from_file verify the checksums if they are already existing
 361     foreach my $file ($checksums->get_files()) {
 362         if (not $checksums->has_strong_checksums($file)) {
 363             if ($self->{options}{require_strong_checksums}) {
 364                 error(g_('source package uses only weak checksums'));
 365             } else {
 366                 $warn_on_weak = 1;
 367             }
 368         }
 369         $checksums->add_from_file($self->{basedir} . $file, key => $file);
 370     }
 371
 372     warning(g_('source package uses only weak checksums')) if $warn_on_weak;
 373 }
 374
 375 sub get_basename {
 376     my ($self, $with_revision) = @_;
 377     my $f = $self->{fields};
 378     unless (exists $f->{'Source'} and exists $f->{'Version'}) {
 379         error(g_('%s and %s fields are required to compute the source basename'),
 380               'Source', 'Version');
 381     }
 382     my $v = Dpkg::Version->new($f->{'Version'});
 383     my $vs = $v->as_string(omit_epoch => 1, omit_revision => !$with_revision);
 384     return $f->{'Source'} . '_' . $vs;
 385 }
 386
 387 sub find_original_tarballs {
 388     my ($self, %opts) = @_;
 389     $opts{extension} //= compression_get_file_extension_regex();
 390     $opts{include_main} //= 1;
 391     $opts{include_supplementary} //= 1;
 392     my $basename = $self->get_basename();
 393     my @tar;
 394     foreach my $dir ('.', $self->{basedir}, $self->{options}{origtardir}) {
 395         next unless defined($dir) and -d $dir;
 396         opendir(my $dir_dh, $dir) or syserr(g_('cannot opendir %s'), $dir);
 397         push @tar, map { "$dir/$_" } grep {
 398                 ($opts{include_main} and
 399                  /^\Q$basename\E\.orig\.tar\.$opts{extension}$/) or
 400                 ($opts{include_supplementary} and
 401                  /^\Q$basename\E\.orig-[[:alnum:]-]+\.tar\.$opts{extension}$/)
 402             } readdir($dir_dh);
 403         closedir($dir_dh);
 404     }
 405     return @tar;
 406 }
 407
 408 =item $bool = $p->is_signed()
 409
 410 Returns 1 if the DSC files contains an embedded OpenPGP signature.
 411 Otherwise returns 0.
 412
 413 =cut
 414
 415 sub is_signed {
 416     my $self = shift;
 417     return $self->{is_signed};
 418 }
 419
 420 =item $p->check_signature()
 421
 422 Implement the same OpenPGP signature check that dpkg-source does.
 423 In case of problems, it prints a warning or errors out.
 424
 425 If the object has been created with the "require_valid_signature" option,
 426 then any problem will result in a fatal error.
 427
 428 =cut
 429
 430 sub check_signature {
 431     my $self = shift;
 432     my $dsc = $self->get_filename();
 433     my @exec;
 434
 435     if (find_command('gpgv2')) {
 436         push @exec, 'gpgv2';
 437     } elsif (find_command('gpgv')) {
 438         push @exec, 'gpgv';
 439     } elsif (find_command('gpg2')) {
 440         push @exec, 'gpg2', '--no-default-keyring', '-q', '--verify';
 441     } elsif (find_command('gpg')) {
 442         push @exec, 'gpg', '--no-default-keyring', '-q', '--verify';
 443     }
 444     if (scalar(@exec)) {
 445         if (length $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") {
 446             push @exec, '--keyring', "$ENV{HOME}/.gnupg/trustedkeys.gpg";
 447         }
 448         foreach my $vendor_keyring (run_vendor_hook('package-keyrings')) {
 449             if (-r $vendor_keyring) {
 450                 push @exec, '--keyring', $vendor_keyring;
 451             }
 452         }
 453         push @exec, $dsc;
 454
 455         my ($stdout, $stderr);
 456         spawn(exec => \@exec, wait_child => 1, nocheck => 1,
 457               to_string => \$stdout, error_to_string => \$stderr,
 458               timeout => 10);
 459         if (WIFEXITED($?)) {
 460             my $gpg_status = WEXITSTATUS($?);
 461             print { *STDERR } "$stdout$stderr" if $gpg_status;
 462             if ($gpg_status == 1 or ($gpg_status &&
 463                 $self->{options}{require_valid_signature}))
 464             {
 465                 error(g_('failed to verify signature on %s'), $dsc);
 466             } elsif ($gpg_status) {
 467                 warning(g_('failed to verify signature on %s'), $dsc);
 468             }
 469         } else {
 470             subprocerr("@exec");
 471         }
 472     } else {
 473         if ($self->{options}{require_valid_signature}) {
 474             error(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc);
 475         } else {
 476             warning(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc);
 477         }
 478     }
 479 }
 480
 481 sub describe_cmdline_options {
 482     return;
 483 }
 484
 485 sub parse_cmdline_options {
 486     my ($self, @opts) = @_;
 487     foreach my $option (@opts) {
 488         if (not $self->parse_cmdline_option($option)) {
 489             warning(g_('%s is not a valid option for %s'), $option, ref $self);
 490         }
 491     }
 492 }
 493
 494 sub parse_cmdline_option {
 495     return 0;
 496 }
 497
 498 =item $p->extract($targetdir)
 499
 500 Extracts the source package in the target directory $targetdir. Beware
 501 that if $targetdir already exists, it will be erased (as long as the
 502 no_overwrite_dir option is set).
 503
 504 =cut
 505
 506 sub extract {
 507     my ($self, $newdirectory) = @_;
 508
 509     my ($ok, $error) = version_check($self->{fields}{'Version'});
 510     if (not $ok) {
 511         if ($self->{options}{ignore_bad_version}) {
 512             warning($error);
 513         } else {
 514             error($error);
 515         }
 516     }
 517
 518     # Copy orig tarballs
 519     if ($self->{options}{copy_orig_tarballs}) {
 520         my $basename = $self->get_basename();
 521         my ($dirname, $destdir) = fileparse($newdirectory);
 522         $destdir ||= './';
 523         my $ext = compression_get_file_extension_regex();
 524         foreach my $orig (grep { /^\Q$basename\E\.orig(-[[:alnum:]-]+)?\.tar\.$ext$/ }
 525                           $self->get_files())
 526         {
 527             my $src = File::Spec->catfile($self->{basedir}, $orig);
 528             my $dst = File::Spec->catfile($destdir, $orig);
 529             if (not check_files_are_the_same($src, $dst, 1)) {
 530                 system('cp', '--', $src, $dst);
 531                 subprocerr("cp $src to $dst") if $?;
 532             }
 533         }
 534     }
 535
 536     # Try extract
 537     eval { $self->do_extract($newdirectory) };
 538     if ($@) {
 539         run_exit_handlers();
 540         die $@;
 541     }
 542
 543     # Store format if non-standard so that next build keeps the same format
 544     if ($self->{fields}{'Format'} ne '1.0' and
 545         not $self->{options}{skip_debianization})
 546     {
 547         my $srcdir = File::Spec->catdir($newdirectory, 'debian', 'source');
 548         my $format_file = File::Spec->catfile($srcdir, 'format');
 549         unless (-e $format_file) {
 550             mkdir($srcdir) unless -e $srcdir;
 551             open(my $format_fh, '>', $format_file)
 552                 or syserr(g_('cannot write %s'), $format_file);
 553             print { $format_fh } $self->{fields}{'Format'} . "\n";
 554             close($format_fh);
 555         }
 556     }
 557
 558     # Make sure debian/rules is executable
 559     my $rules = File::Spec->catfile($newdirectory, 'debian', 'rules');
 560     my @s = lstat($rules);
 561     if (not scalar(@s)) {
 562         unless ($! == ENOENT) {
 563             syserr(g_('cannot stat %s'), $rules);
 564         }
 565         warning(g_('%s does not exist'), $rules)
 566             unless $self->{options}{skip_debianization};
 567     } elsif (-f _) {
 568         chmod($s[2] | 0111, $rules)
 569             or syserr(g_('cannot make %s executable'), $rules);
 570     } else {
 571         warning(g_('%s is not a plain file'), $rules);
 572     }
 573 }
 574
 575 sub do_extract {
 576     croak 'Dpkg::Source::Package does not know how to unpack a ' .
 577           'source package; use one of the subclasses';
 578 }
 579
 580 # Function used specifically during creation of a source package
 581
 582 sub before_build {
 583     my ($self, $dir) = @_;
 584 }
 585
 586 sub build {
 587     my $self = shift;
 588     eval { $self->do_build(@_) };
 589     if ($@) {
 590         run_exit_handlers();
 591         die $@;
 592     }
 593 }
 594
 595 sub after_build {
 596     my ($self, $dir) = @_;
 597 }
 598
 599 sub do_build {
 600     croak 'Dpkg::Source::Package does not know how to build a ' .
 601           'source package; use one of the subclasses';
 602 }
 603
 604 sub can_build {
 605     my ($self, $dir) = @_;
 606     return (0, 'can_build() has not been overridden');
 607 }
 608
 609 sub add_file {
 610     my ($self, $filename) = @_;
 611     my ($fn, $dir) = fileparse($filename);
 612     if ($self->{checksums}->has_file($fn)) {
 613         croak "tried to add file '$fn' twice";
 614     }
 615     $self->{checksums}->add_from_file($filename, key => $fn);
 616     $self->{checksums}->export_to_control($self->{fields},
 617                                             use_files_for_md5 => 1);
 618 }
 619
 620 sub commit {
 621     my $self = shift;
 622     eval { $self->do_commit(@_) };
 623     if ($@) {
 624         run_exit_handlers();
 625         die $@;
 626     }
 627 }
 628
 629 sub do_commit {
 630     my ($self, $dir) = @_;
 631     info(g_("'%s' is not supported by the source format '%s'"),
 632          'dpkg-source --commit', $self->{fields}{'Format'});
 633 }
 634
 635 sub write_dsc {
 636     my ($self, %opts) = @_;
 637     my $fields = $self->{fields};
 638
 639     foreach my $f (keys %{$opts{override}}) {
 640         $fields->{$f} = $opts{override}{$f};
 641     }
 642
 643     unless ($opts{nocheck}) {
 644         foreach my $f (qw(Source Version Architecture)) {
 645             unless (defined($fields->{$f})) {
 646                 error(g_('missing information for critical output field %s'), $f);
 647             }
 648         }
 649         foreach my $f (qw(Maintainer Standards-Version)) {
 650             unless (defined($fields->{$f})) {
 651                 warning(g_('missing information for output field %s'), $f);
 652             }
 653         }
 654     }
 655
 656     foreach my $f (keys %{$opts{remove}}) {
 657         delete $fields->{$f};
 658     }
 659
 660     my $filename = $opts{filename};
 661     $filename //= $self->get_basename(1) . '.dsc';
 662     open(my $dsc_fh, '>', $filename)
 663         or syserr(g_('cannot write %s'), $filename);
 664     $fields->apply_substvars($opts{substvars});
 665     $fields->output($dsc_fh);
 666     close($dsc_fh);
 667 }
 668
 669 =back
 670
 671 =head1 CHANGES
 672
 673 =head2 Version 1.02 (dpkg 1.18.7)
 674
 675 New option: require_strong_checksums in check_checksums().
 676
 677 =head2 Version 1.01 (dpkg 1.17.2)
 678
 679 New functions: get_default_diff_ignore_regex(), set_default_diff_ignore_regex(),
 680 get_default_tar_ignore_pattern()
 681
 682 Deprecated variables: $diff_ignore_default_regexp, @tar_ignore_default_pattern
 683
 684 =head2 Version 1.00 (dpkg 1.16.1)
 685
 686 Mark the module as public.
 687
 688 =cut
 689
 690 1;