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