chiark - git - mdw - dpkg/blob - scripts/Dpkg/Source/Package/V2.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::V2;
  18
  19 use strict;
  20 use warnings;
  21
  22 our $VERSION = '0.01';
  23
  24 use POSIX qw(:errno_h);
  25 use List::Util qw(first);
  26 use Cwd;
  27 use File::Basename;
  28 use File::Temp qw(tempfile tempdir);
  29 use File::Path qw(make_path);
  30 use File::Spec;
  31 use File::Find;
  32 use File::Copy;
  33
  34 use Dpkg::Gettext;
  35 use Dpkg::ErrorHandling;
  36 use Dpkg::File;
  37 use Dpkg::Path qw(find_command);
  38 use Dpkg::Compression;
  39 use Dpkg::Source::Archive;
  40 use Dpkg::Source::Patch;
  41 use Dpkg::Exit qw(push_exit_handler pop_exit_handler);
  42 use Dpkg::Source::Functions qw(erasedir is_binary fs_time);
  43 use Dpkg::Vendor qw(run_vendor_hook);
  44 use Dpkg::Control;
  45 use Dpkg::Changelog::Parse;
  46
  47 use parent qw(Dpkg::Source::Package);
  48
  49 our $CURRENT_MINOR_VERSION = '0';
  50
  51 sub init_options {
  52     my $self = shift;
  53     $self->SUPER::init_options();
  54     $self->{options}{include_removal} //= 0;
  55     $self->{options}{include_timestamp} //= 0;
  56     $self->{options}{include_binaries} //= 0;
  57     $self->{options}{preparation} //= 1;
  58     $self->{options}{skip_patches} //= 0;
  59     $self->{options}{unapply_patches} //= 'auto';
  60     $self->{options}{skip_debianization} //= 0;
  61     $self->{options}{create_empty_orig} //= 0;
  62     $self->{options}{auto_commit} //= 0;
  63     $self->{options}{ignore_bad_version} //= 0;
  64 }
  65
  66 my @module_cmdline = (
  67     {
  68         name => '--include-removal',
  69         help => N_('include removed files in the patch'),
  70         when => 'build',
  71     }, {
  72         name => '--include-timestamp',
  73         help => N_('include timestamp in the patch'),
  74         when => 'build',
  75     }, {
  76         name => '--include-binaries',
  77         help => N_('include binary files in the tarball'),
  78         when => 'build',
  79     }, {
  80         name => '--no-preparation',
  81         help => N_('do not prepare build tree by applying patches'),
  82         when => 'build',
  83     }, {
  84         name => '--no-unapply-patches',
  85         help => N_('do not unapply patches if previously applied'),
  86         when => 'build',
  87     }, {
  88         name => '--unapply-patches',
  89         help => N_('unapply patches if previously applied (default)'),
  90         when => 'build',
  91     }, {
  92         name => '--create-empty-orig',
  93         help => N_('create an empty original tarball if missing'),
  94         when => 'build',
  95     }, {
  96         name => '--abort-on-upstream-changes',
  97         help => N_('abort if generated diff has upstream files changes'),
  98         when => 'build',
  99     }, {
 100         name => '--auto-commit',
 101         help => N_('record generated patches, instead of aborting'),
 102         when => 'build',
 103     }, {
 104         name => '--skip-debianization',
 105         help => N_('do not extract debian tarball into upstream sources'),
 106         when => 'extract',
 107     }, {
 108         name => '--skip-patches',
 109         help => N_('do not apply patches at the end of the extraction'),
 110         when => 'extract',
 111     }
 112 );
 113
 114 sub describe_cmdline_options {
 115     return @module_cmdline;
 116 }
 117
 118 sub parse_cmdline_option {
 119     my ($self, $opt) = @_;
 120     if ($opt eq '--include-removal') {
 121         $self->{options}{include_removal} = 1;
 122         return 1;
 123     } elsif ($opt eq '--include-timestamp') {
 124         $self->{options}{include_timestamp} = 1;
 125         return 1;
 126     } elsif ($opt eq '--include-binaries') {
 127         $self->{options}{include_binaries} = 1;
 128         return 1;
 129     } elsif ($opt eq '--no-preparation') {
 130         $self->{options}{preparation} = 0;
 131         return 1;
 132     } elsif ($opt eq '--skip-patches') {
 133         $self->{options}{skip_patches} = 1;
 134         return 1;
 135     } elsif ($opt eq '--unapply-patches') {
 136         $self->{options}{unapply_patches} = 'yes';
 137         return 1;
 138     } elsif ($opt eq '--no-unapply-patches') {
 139         $self->{options}{unapply_patches} = 'no';
 140         return 1;
 141     } elsif ($opt eq '--skip-debianization') {
 142         $self->{options}{skip_debianization} = 1;
 143         return 1;
 144     } elsif ($opt eq '--create-empty-orig') {
 145         $self->{options}{create_empty_orig} = 1;
 146         return 1;
 147     } elsif ($opt eq '--abort-on-upstream-changes') {
 148         $self->{options}{auto_commit} = 0;
 149         return 1;
 150     } elsif ($opt eq '--auto-commit') {
 151         $self->{options}{auto_commit} = 1;
 152         return 1;
 153     } elsif ($opt eq '--ignore-bad-version') {
 154         $self->{options}{ignore_bad_version} = 1;
 155         return 1;
 156     }
 157     return 0;
 158 }
 159
 160 sub do_extract {
 161     my ($self, $newdirectory) = @_;
 162     my $fields = $self->{fields};
 163
 164     my $dscdir = $self->{basedir};
 165
 166     my $basename = $self->get_basename();
 167     my $basenamerev = $self->get_basename(1);
 168
 169     my ($tarfile, $debianfile, %addonfile, %seen);
 170     my ($tarsign, %addonsign);
 171     my $re_ext = compression_get_file_extension_regex();
 172     foreach my $file ($self->get_files()) {
 173         my $uncompressed = $file;
 174         $uncompressed =~ s/\.$re_ext$/.*/;
 175         $uncompressed =~ s/\.$re_ext\.asc$/.*.asc/;
 176         error(g_('duplicate files in %s source package: %s'), 'v2.0',
 177               $uncompressed) if $seen{$uncompressed};
 178         $seen{$uncompressed} = 1;
 179         if ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext$/) {
 180             $tarfile = $file;
 181         } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext\.asc$/) {
 182             $tarsign = $file;
 183         } elsif ($file =~ /^\Q$basename\E\.orig-([[:alnum:]-]+)\.tar\.$re_ext$/) {
 184             $addonfile{$1} = $file;
 185         } elsif ($file =~ /^\Q$basename\E\.orig-([[:alnum:]-]+)\.tar\.$re_ext\.asc$/) {
 186             $addonsign{$1} = $file;
 187         } elsif ($file =~ /^\Q$basenamerev\E\.debian\.tar\.$re_ext$/) {
 188             $debianfile = $file;
 189         } else {
 190             error(g_('unrecognized file for a %s source package: %s'),
 191             'v2.0', $file);
 192         }
 193     }
 194
 195     unless ($tarfile and $debianfile) {
 196         error(g_('missing orig.tar or debian.tar file in v2.0 source package'));
 197     }
 198     if ($tarsign and $tarfile ne substr $tarsign, 0, -4) {
 199         error(g_('mismatched orig.tar %s for signature %s in source package'),
 200               $tarfile, $tarsign);
 201     }
 202     foreach my $name (keys %addonsign) {
 203         error(g_('missing addon orig.tar for signature %s in source package'),
 204               $addonsign{$name})
 205             if not exists $addonfile{$name};
 206         error(g_('mismatched addon orig.tar %s for signature %s in source package'),
 207               $addonfile{$name}, $addonsign{$name})
 208             if $addonfile{$name} ne substr $addonsign{$name}, 0, -4;
 209     }
 210
 211     if ($self->{options}{no_overwrite_dir} and -e $newdirectory) {
 212         error(g_('unpack target exists: %s'), $newdirectory);
 213     } else {
 214         erasedir($newdirectory);
 215     }
 216
 217     # Extract main tarball
 218     info(g_('unpacking %s'), $tarfile);
 219     my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
 220     $tar->extract($newdirectory, no_fixperms => 1,
 221                   options => [ '--anchored', '--no-wildcards-match-slash',
 222                                '--exclude', '*/.pc', '--exclude', '.pc' ]);
 223     # The .pc exclusion is only needed for 3.0 (quilt) and to avoid
 224     # having an upstream tarball provide a directory with symlinks
 225     # that would be blindly followed when applying the patches
 226
 227     # Extract additional orig tarballs
 228     foreach my $subdir (sort keys %addonfile) {
 229         my $file = $addonfile{$subdir};
 230         info(g_('unpacking %s'), $file);
 231
 232         # If the pathname is an empty directory, just silently remove it, as
 233         # it might be part of a git repository, as a submodule for example.
 234         rmdir "$newdirectory/$subdir";
 235         if (-e "$newdirectory/$subdir") {
 236             warning(g_("required removal of '%s' installed by original tarball"),
 237                     $subdir);
 238             erasedir("$newdirectory/$subdir");
 239         }
 240         $tar = Dpkg::Source::Archive->new(filename => "$dscdir$file");
 241         $tar->extract("$newdirectory/$subdir", no_fixperms => 1);
 242     }
 243
 244     # Stop here if debianization is not wanted
 245     return if $self->{options}{skip_debianization};
 246
 247     # Extract debian tarball after removing the debian directory
 248     info(g_('unpacking %s'), $debianfile);
 249     erasedir("$newdirectory/debian");
 250     $tar = Dpkg::Source::Archive->new(filename => "$dscdir$debianfile");
 251     $tar->extract($newdirectory, in_place => 1);
 252
 253     # Apply patches (in a separate method as it might be overridden)
 254     $self->apply_patches($newdirectory, usage => 'unpack')
 255         unless $self->{options}{skip_patches};
 256 }
 257
 258 sub get_autopatch_name {
 259     return 'zz_debian-diff-auto';
 260 }
 261
 262 sub _get_patches {
 263     my ($self, $dir, %opts) = @_;
 264     $opts{skip_auto} //= 0;
 265     my @patches;
 266     my $pd = "$dir/debian/patches";
 267     my $auto_patch = $self->get_autopatch_name();
 268     if (-d $pd) {
 269         opendir(my $dir_dh, $pd) or syserr(g_('cannot opendir %s'), $pd);
 270         foreach my $patch (sort readdir($dir_dh)) {
 271             # patches match same rules as run-parts
 272             next unless $patch =~ /^[\w-]+$/ and -f "$pd/$patch";
 273             next if $opts{skip_auto} and $patch eq $auto_patch;
 274             push @patches, $patch;
 275         }
 276         closedir($dir_dh);
 277     }
 278     return @patches;
 279 }
 280
 281 sub apply_patches {
 282     my ($self, $dir, %opts) = @_;
 283     $opts{skip_auto} //= 0;
 284     my @patches = $self->_get_patches($dir, %opts);
 285     return unless scalar(@patches);
 286     my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
 287     open(my $applied_fh, '>', $applied)
 288         or syserr(g_('cannot write %s'), $applied);
 289     print { $applied_fh } "# During $opts{usage}\n";
 290     my $timestamp = fs_time($applied);
 291     foreach my $patch ($self->_get_patches($dir, %opts)) {
 292         my $path = File::Spec->catfile($dir, 'debian', 'patches', $patch);
 293         info(g_('applying %s'), $patch) unless $opts{skip_auto};
 294         my $patch_obj = Dpkg::Source::Patch->new(filename => $path);
 295         $patch_obj->apply($dir, force_timestamp => 1,
 296                           timestamp => $timestamp,
 297                           add_options => [ '-E' ]);
 298         print { $applied_fh } "$patch\n";
 299     }
 300     close($applied_fh);
 301 }
 302
 303 sub unapply_patches {
 304     my ($self, $dir, %opts) = @_;
 305     my @patches = reverse($self->_get_patches($dir, %opts));
 306     return unless scalar(@patches);
 307     my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
 308     my $timestamp = fs_time($applied);
 309     foreach my $patch (@patches) {
 310         my $path = File::Spec->catfile($dir, 'debian', 'patches', $patch);
 311         info(g_('unapplying %s'), $patch) unless $opts{quiet};
 312         my $patch_obj = Dpkg::Source::Patch->new(filename => $path);
 313         $patch_obj->apply($dir, force_timestamp => 1, verbose => 0,
 314                           timestamp => $timestamp,
 315                           add_options => [ '-E', '-R' ]);
 316     }
 317     unlink($applied);
 318 }
 319
 320 sub _upstream_tarball_template {
 321     my $self = shift;
 322     my $ext = '{' . join(',',
 323         sort map {
 324             compression_get_property($_, 'file_ext')
 325         } compression_get_list()) . '}';
 326     return '../' . $self->get_basename() . ".orig.tar.$ext";
 327 }
 328
 329 sub can_build {
 330     my ($self, $dir) = @_;
 331     return 1 if $self->find_original_tarballs(include_supplementary => 0);
 332     return 1 if $self->{options}{create_empty_orig} and
 333                 $self->find_original_tarballs(include_main => 0);
 334     return (0, sprintf(g_('no upstream tarball found at %s'),
 335                        $self->_upstream_tarball_template()));
 336 }
 337
 338 sub before_build {
 339     my ($self, $dir) = @_;
 340     $self->check_patches_applied($dir) if $self->{options}{preparation};
 341 }
 342
 343 sub after_build {
 344     my ($self, $dir) = @_;
 345     my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
 346     my $reason = '';
 347     if (-e $applied) {
 348         open(my $applied_fh, '<', $applied)
 349             or syserr(g_('cannot read %s'), $applied);
 350         $reason = <$applied_fh>;
 351         close($applied_fh);
 352     }
 353     my $opt_unapply = $self->{options}{unapply_patches};
 354     if (($opt_unapply eq 'auto' and $reason =~ /^# During preparation/) or
 355         $opt_unapply eq 'yes') {
 356         $self->unapply_patches($dir);
 357     }
 358 }
 359
 360 sub prepare_build {
 361     my ($self, $dir) = @_;
 362     $self->{diff_options} = {
 363         diff_ignore_regex => $self->{options}{diff_ignore_regex} .
 364                              '|(^|/)debian/patches/.dpkg-source-applied$',
 365         include_removal => $self->{options}{include_removal},
 366         include_timestamp => $self->{options}{include_timestamp},
 367         use_dev_null => 1,
 368     };
 369     push @{$self->{options}{tar_ignore}}, 'debian/patches/.dpkg-source-applied';
 370     $self->check_patches_applied($dir) if $self->{options}{preparation};
 371     if ($self->{options}{create_empty_orig} and
 372         not $self->find_original_tarballs(include_supplementary => 0))
 373     {
 374         # No main orig.tar, create a dummy one
 375         my $filename = $self->get_basename() . '.orig.tar.' .
 376                        $self->{options}{comp_ext};
 377         my $tar = Dpkg::Source::Archive->new(filename => $filename,
 378                                              compression_level => $self->{options}{comp_level});
 379         $tar->create();
 380         $tar->finish();
 381     }
 382 }
 383
 384 sub check_patches_applied {
 385     my ($self, $dir) = @_;
 386     my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
 387     unless (-e $applied) {
 388         info(g_('patches are not applied, applying them now'));
 389         $self->apply_patches($dir, usage => 'preparation');
 390     }
 391 }
 392
 393 sub _generate_patch {
 394     my ($self, $dir, %opts) = @_;
 395     my ($dirname, $updir) = fileparse($dir);
 396     my $basedirname = $self->get_basename();
 397     $basedirname =~ s/_/-/;
 398
 399     # Identify original tarballs
 400     my ($tarfile, %addonfile);
 401     my $comp_ext_regex = compression_get_file_extension_regex();
 402     my @origtarballs;
 403     foreach my $file (sort $self->find_original_tarballs()) {
 404         if ($file =~ /\.orig\.tar\.$comp_ext_regex$/) {
 405             if (defined($tarfile)) {
 406                 error(g_('several orig.tar files found (%s and %s) but only ' .
 407                          'one is allowed'), $tarfile, $file);
 408             }
 409             $tarfile = $file;
 410             push @origtarballs, $file;
 411             $self->add_file($file);
 412             $self->add_file("$file.asc") if -e "$file.asc";
 413         } elsif ($file =~ /\.orig-([[:alnum:]-]+)\.tar\.$comp_ext_regex$/) {
 414             $addonfile{$1} = $file;
 415             push @origtarballs, $file;
 416             $self->add_file($file);
 417             $self->add_file("$file.asc") if -e "$file.asc";
 418         }
 419     }
 420
 421     error(g_('no upstream tarball found at %s'),
 422           $self->_upstream_tarball_template()) unless $tarfile;
 423
 424     if ($opts{usage} eq 'build') {
 425         info(g_('building %s using existing %s'),
 426              $self->{fields}{'Source'}, "@origtarballs");
 427     }
 428
 429     # Unpack a second copy for comparison
 430     my $tmp = tempdir("$dirname.orig.XXXXXX", DIR => $updir);
 431     push_exit_handler(sub { erasedir($tmp) });
 432
 433     # Extract main tarball
 434     my $tar = Dpkg::Source::Archive->new(filename => $tarfile);
 435     $tar->extract($tmp);
 436
 437     # Extract additional orig tarballs
 438     foreach my $subdir (keys %addonfile) {
 439         my $file = $addonfile{$subdir};
 440         $tar = Dpkg::Source::Archive->new(filename => $file);
 441         $tar->extract("$tmp/$subdir");
 442     }
 443
 444     # Copy over the debian directory
 445     erasedir("$tmp/debian");
 446     system('cp', '-a', '--', "$dir/debian", "$tmp/");
 447     subprocerr(g_('copy of the debian directory')) if $?;
 448
 449     # Apply all patches except the last automatic one
 450     $opts{skip_auto} //= 0;
 451     $self->apply_patches($tmp, skip_auto => $opts{skip_auto}, usage => 'build');
 452
 453     # Create a patch
 454     my ($difffh, $tmpdiff) = tempfile($self->get_basename(1) . '.diff.XXXXXX',
 455                                       TMPDIR => 1, UNLINK => 0);
 456     push_exit_handler(sub { unlink($tmpdiff) });
 457     my $diff = Dpkg::Source::Patch->new(filename => $tmpdiff,
 458                                         compression => 'none');
 459     $diff->create();
 460     if ($opts{header_from} and -e $opts{header_from}) {
 461         my $header_from = Dpkg::Source::Patch->new(
 462             filename => $opts{header_from});
 463         my $analysis = $header_from->analyze($dir, verbose => 0);
 464         $diff->set_header($analysis->{patchheader});
 465     } else {
 466         $diff->set_header($self->_get_patch_header($dir));
 467     }
 468     $diff->add_diff_directory($tmp, $dir, basedirname => $basedirname,
 469             %{$self->{diff_options}},
 470             handle_binary_func => $opts{handle_binary},
 471             order_from => $opts{order_from});
 472     error(g_('unrepresentable changes to source')) if not $diff->finish();
 473
 474     if (-s $tmpdiff) {
 475         info(g_('local changes detected, the modified files are:'));
 476         my $analysis = $diff->analyze($dir, verbose => 0);
 477         foreach my $fn (sort keys %{$analysis->{filepatched}}) {
 478             print " $fn\n";
 479         }
 480     }
 481
 482     # Remove the temporary directory
 483     erasedir($tmp);
 484     pop_exit_handler();
 485     pop_exit_handler();
 486
 487     return $tmpdiff;
 488 }
 489
 490 sub do_build {
 491     my ($self, $dir) = @_;
 492     my @argv = @{$self->{options}{ARGV}};
 493     if (scalar(@argv)) {
 494         usageerr(g_("-b takes only one parameter with format '%s'"),
 495                  $self->{fields}{'Format'});
 496     }
 497     $self->prepare_build($dir);
 498
 499     my $include_binaries = $self->{options}{include_binaries};
 500     my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}};
 501
 502     my $sourcepackage = $self->{fields}{'Source'};
 503     my $basenamerev = $self->get_basename(1);
 504
 505     # Check if the debian directory contains unwanted binary files
 506     my $binaryfiles = Dpkg::Source::Package::V2::BinaryFiles->new($dir);
 507     my $unwanted_binaries = 0;
 508     my $check_binary = sub {
 509         if (-f and is_binary($_)) {
 510             my $fn = File::Spec->abs2rel($_, $dir);
 511             $binaryfiles->new_binary_found($fn);
 512             unless ($include_binaries or $binaryfiles->binary_is_allowed($fn)) {
 513                 errormsg(g_('unwanted binary file: %s'), $fn);
 514                 $unwanted_binaries++;
 515             }
 516         }
 517     };
 518     my $tar_ignore_glob = '{' . join(',',
 519         map { s/,/\\,/rg } @{$self->{options}{tar_ignore}}) . '}';
 520     my $filter_ignore = sub {
 521         # Filter out files that are not going to be included in the debian
 522         # tarball due to ignores.
 523         my %exclude;
 524         my $reldir = File::Spec->abs2rel($File::Find::dir, $dir);
 525         my $cwd = getcwd();
 526         # Apply the pattern both from the top dir and from the inspected dir
 527         chdir $dir or syserr(g_("unable to chdir to '%s'"), $dir);
 528         $exclude{$_} = 1 foreach glob($tar_ignore_glob);
 529         chdir $cwd or syserr(g_("unable to chdir to '%s'"), $cwd);
 530         chdir($File::Find::dir)
 531             or syserr(g_("unable to chdir to '%s'"), $File::Find::dir);
 532         $exclude{$_} = 1 foreach glob($tar_ignore_glob);
 533         chdir $cwd or syserr(g_("unable to chdir to '%s'"), $cwd);
 534         my @result;
 535         foreach my $fn (@_) {
 536             unless (exists $exclude{$fn} or exists $exclude{"$reldir/$fn"}) {
 537                 push @result, $fn;
 538             }
 539         }
 540         return @result;
 541     };
 542     find({ wanted => $check_binary, preprocess => $filter_ignore,
 543            no_chdir => 1 }, File::Spec->catdir($dir, 'debian'));
 544     error(P_('detected %d unwanted binary file (add it in ' .
 545              'debian/source/include-binaries to allow its inclusion).',
 546              'detected %d unwanted binary files (add them in ' .
 547              'debian/source/include-binaries to allow their inclusion).',
 548              $unwanted_binaries), $unwanted_binaries)
 549          if $unwanted_binaries;
 550
 551     # Handle modified binary files detected by the auto-patch generation
 552     my $handle_binary = sub {
 553         my ($self, $old, $new, %opts) = @_;
 554
 555         my $file = $opts{filename};
 556         $binaryfiles->new_binary_found($file);
 557         unless ($include_binaries or $binaryfiles->binary_is_allowed($file)) {
 558             errormsg(g_('cannot represent change to %s: %s'), $file,
 559                      g_('binary file contents changed'));
 560             errormsg(g_('add %s in debian/source/include-binaries if you want ' .
 561                         'to store the modified binary in the debian tarball'),
 562                      $file);
 563             $self->register_error();
 564         }
 565     };
 566
 567     # Create a patch
 568     my $autopatch = File::Spec->catfile($dir, 'debian', 'patches',
 569                                         $self->get_autopatch_name());
 570     my $tmpdiff = $self->_generate_patch($dir, order_from => $autopatch,
 571                                         header_from => $autopatch,
 572                                         handle_binary => $handle_binary,
 573                                         skip_auto => $self->{options}{auto_commit},
 574                                         usage => 'build');
 575     unless (-z $tmpdiff or $self->{options}{auto_commit}) {
 576         info(g_('you can integrate the local changes with %s'),
 577              'dpkg-source --commit');
 578         error(g_('aborting due to unexpected upstream changes, see %s'),
 579               $tmpdiff);
 580     }
 581     push_exit_handler(sub { unlink($tmpdiff) });
 582     $binaryfiles->update_debian_source_include_binaries() if $include_binaries;
 583
 584     # Install the diff as the new autopatch
 585     if ($self->{options}{auto_commit}) {
 586         make_path(File::Spec->catdir($dir, 'debian', 'patches'));
 587         $autopatch = $self->register_patch($dir, $tmpdiff,
 588                                            $self->get_autopatch_name());
 589         info(g_('local changes have been recorded in a new patch: %s'),
 590              $autopatch) if -e $autopatch;
 591         rmdir(File::Spec->catdir($dir, 'debian', 'patches')); # No check on purpose
 592     }
 593     unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff);
 594     pop_exit_handler();
 595
 596     # Create the debian.tar
 597     my $debianfile = "$basenamerev.debian.tar." . $self->{options}{comp_ext};
 598     info(g_('building %s in %s'), $sourcepackage, $debianfile);
 599     my $tar = Dpkg::Source::Archive->new(filename => $debianfile,
 600                                          compression_level => $self->{options}{comp_level});
 601     $tar->create(options => \@tar_ignore, chdir => $dir);
 602     $tar->add_directory('debian');
 603     foreach my $binary ($binaryfiles->get_seen_binaries()) {
 604         $tar->add_file($binary) unless $binary =~ m{^debian/};
 605     }
 606     $tar->finish();
 607
 608     $self->add_file($debianfile);
 609 }
 610
 611 sub _get_patch_header {
 612     my ($self, $dir) = @_;
 613     my $ph = File::Spec->catfile($dir, 'debian', 'source', 'local-patch-header');
 614     unless (-f $ph) {
 615         $ph = File::Spec->catfile($dir, 'debian', 'source', 'patch-header');
 616     }
 617     my $text;
 618     if (-f $ph) {
 619         open(my $ph_fh, '<', $ph) or syserr(g_('cannot read %s'), $ph);
 620         $text = file_slurp($ph_fh);
 621         close($ph_fh);
 622         return $text;
 623     }
 624     my $ch_info = changelog_parse(offset => 0, count => 1,
 625         file => File::Spec->catfile($dir, 'debian', 'changelog'));
 626     return '' if not defined $ch_info;
 627     my $header = Dpkg::Control->new(type => CTRL_UNKNOWN);
 628     $header->{'Description'} = "<short summary of the patch>\n";
 629     $header->{'Description'} .=
 630 "TODO: Put a short summary on the line above and replace this paragraph
 631 with a longer explanation of this change. Complete the meta-information
 632 with other relevant fields (see below for details). To make it easier, the
 633 information below has been extracted from the changelog. Adjust it or drop
 634 it.\n";
 635     $header->{'Description'} .= $ch_info->{'Changes'} . "\n";
 636     $header->{'Author'} = $ch_info->{'Maintainer'};
 637     my $yyyy_mm_dd = POSIX::strftime('%Y-%m-%d', gmtime);
 638
 639     $text = "$header";
 640     run_vendor_hook('extend-patch-header', \$text, $ch_info);
 641     $text .= "\n---
 642 The information above should follow the Patch Tagging Guidelines, please
 643 checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
 644 are templates for supplementary fields that you might want to add:
 645
 646 Origin: <vendor|upstream|other>, <url of original patch>
 647 Bug: <url in upstream bugtracker>
 648 Bug-Debian: https://bugs.debian.org/<bugnumber>
 649 Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
 650 Forwarded: <no|not-needed|url proving that it has been forwarded>
 651 Reviewed-By: <name and email of someone who approved the patch>
 652 Last-Update: $yyyy_mm_dd\n\n";
 653     return $text;
 654 }
 655
 656 sub register_patch {
 657     my ($self, $dir, $patch_file, $patch_name) = @_;
 658     my $patch = File::Spec->catfile($dir, 'debian', 'patches', $patch_name);
 659     if (-s $patch_file) {
 660         copy($patch_file, $patch)
 661             or syserr(g_('failed to copy %s to %s'), $patch_file, $patch);
 662         chmod(0666 & ~ umask(), $patch)
 663             or syserr(g_("unable to change permission of '%s'"), $patch);
 664         my $applied = File::Spec->catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
 665         open(my $applied_fh, '>>', $applied)
 666             or syserr(g_('cannot write %s'), $applied);
 667         print { $applied_fh } "$patch\n";
 668         close($applied_fh) or syserr(g_('cannot close %s'), $applied);
 669     } elsif (-e $patch) {
 670         unlink($patch) or syserr(g_('cannot remove %s'), $patch);
 671     }
 672     return $patch;
 673 }
 674
 675 sub _is_bad_patch_name {
 676     my ($dir, $patch_name) = @_;
 677
 678     return 1 if not defined($patch_name);
 679     return 1 if not length($patch_name);
 680
 681     my $patch = File::Spec->catfile($dir, 'debian', 'patches', $patch_name);
 682     if (-e $patch) {
 683         warning(g_('cannot register changes in %s, this patch already exists'),
 684                 $patch);
 685         return 1;
 686     }
 687     return 0;
 688 }
 689
 690 sub do_commit {
 691     my ($self, $dir) = @_;
 692     my ($patch_name, $tmpdiff) = @{$self->{options}{ARGV}};
 693
 694     $self->prepare_build($dir);
 695
 696     # Try to fix up a broken relative filename for the patch
 697     if ($tmpdiff and not -e $tmpdiff) {
 698         $tmpdiff = File::Spec->catfile($dir, $tmpdiff)
 699             unless File::Spec->file_name_is_absolute($tmpdiff);
 700         error(g_("patch file '%s' doesn't exist"), $tmpdiff) if not -e $tmpdiff;
 701     }
 702
 703     my $binaryfiles = Dpkg::Source::Package::V2::BinaryFiles->new($dir);
 704     my $handle_binary = sub {
 705         my ($self, $old, $new, %opts) = @_;
 706         my $fn = File::Spec->abs2rel($new, $dir);
 707         $binaryfiles->new_binary_found($fn);
 708     };
 709
 710     unless ($tmpdiff) {
 711         $tmpdiff = $self->_generate_patch($dir, handle_binary => $handle_binary,
 712                                          usage => 'commit');
 713         $binaryfiles->update_debian_source_include_binaries();
 714     }
 715     push_exit_handler(sub { unlink($tmpdiff) });
 716     unless (-s $tmpdiff) {
 717         unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff);
 718         info(g_('there are no local changes to record'));
 719         return;
 720     }
 721     while (_is_bad_patch_name($dir, $patch_name)) {
 722         # Ask the patch name interactively
 723         print g_('Enter the desired patch name: ');
 724         $patch_name = <STDIN>;
 725         if (not defined $patch_name) {
 726             error(g_('no patch name given; cannot proceed'));
 727         }
 728         chomp $patch_name;
 729         $patch_name =~ s/\s+/-/g;
 730         $patch_name =~ s/\///g;
 731     }
 732     make_path(File::Spec->catdir($dir, 'debian', 'patches'));
 733     my $patch = $self->register_patch($dir, $tmpdiff, $patch_name);
 734     my @editors = ('sensible-editor', $ENV{VISUAL}, $ENV{EDITOR}, 'vi');
 735     my $editor = first { find_command($_) } @editors;
 736     if (not $editor) {
 737         error(g_('cannot find an editor'));
 738     }
 739     system($editor, $patch);
 740     subprocerr($editor) if $?;
 741     unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff);
 742     pop_exit_handler();
 743     info(g_('local changes have been recorded in a new patch: %s'), $patch);
 744 }
 745
 746 package Dpkg::Source::Package::V2::BinaryFiles;
 747
 748 use Dpkg::ErrorHandling;
 749 use Dpkg::Gettext;
 750
 751 use File::Path qw(make_path);
 752 use File::Spec;
 753
 754 sub new {
 755     my ($this, $dir) = @_;
 756     my $class = ref($this) || $this;
 757
 758     my $self = {
 759         dir => $dir,
 760         allowed_binaries => {},
 761         seen_binaries => {},
 762         include_binaries_path =>
 763             File::Spec->catfile($dir, 'debian', 'source', 'include-binaries'),
 764     };
 765     bless $self, $class;
 766     $self->load_allowed_binaries();
 767     return $self;
 768 }
 769
 770 sub new_binary_found {
 771     my ($self, $path) = @_;
 772
 773     $self->{seen_binaries}{$path} = 1;
 774 }
 775
 776 sub load_allowed_binaries {
 777     my $self = shift;
 778     my $incbin_file = $self->{include_binaries_path};
 779     if (-f $incbin_file) {
 780         open(my $incbin_fh, '<', $incbin_file)
 781             or syserr(g_('cannot read %s'), $incbin_file);
 782         while (<$incbin_fh>) {
 783             chomp;
 784             s/^\s*//;
 785             s/\s*$//;
 786             next if /^#/ or length == 0;
 787             $self->{allowed_binaries}{$_} = 1;
 788         }
 789         close($incbin_fh);
 790     }
 791 }
 792
 793 sub binary_is_allowed {
 794     my ($self, $path) = @_;
 795     return 1 if exists $self->{allowed_binaries}{$path};
 796     return 0;
 797 }
 798
 799 sub update_debian_source_include_binaries {
 800     my $self = shift;
 801
 802     my @unknown_binaries = $self->get_unknown_binaries();
 803     return unless scalar(@unknown_binaries);
 804
 805     my $incbin_file = $self->{include_binaries_path};
 806     make_path(File::Spec->catdir($self->{dir}, 'debian', 'source'));
 807     open(my $incbin_fh, '>>', $incbin_file)
 808         or syserr(g_('cannot write %s'), $incbin_file);
 809     foreach my $binary (@unknown_binaries) {
 810         print { $incbin_fh } "$binary\n";
 811         info(g_('adding %s to %s'), $binary, 'debian/source/include-binaries');
 812         $self->{allowed_binaries}{$binary} = 1;
 813     }
 814     close($incbin_fh);
 815 }
 816
 817 sub get_unknown_binaries {
 818     my $self = shift;
 819     return grep { not $self->binary_is_allowed($_) } $self->get_seen_binaries();
 820 }
 821
 822 sub get_seen_binaries {
 823     my $self = shift;
 824     my @seen = sort keys %{$self->{seen_binaries}};
 825     return @seen;
 826 }
 827
 828 1;