<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># Copyright Â© 2008-2011 RaphaÃ«l Hertzog &lt;hertzog@debian.org&gt;
# Copyright Â© 2008-2015 Guillem Jover &lt;guillem@debian.org&gt;
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see &lt;https://www.gnu.org/licenses/&gt;.

package Dpkg::Source::Package::V2;

use strict;
use warnings;

our $VERSION = '0.01';

use List::Util qw(first);
use Cwd;
use File::Basename;
use File::Temp qw(tempfile tempdir);
use File::Path qw(make_path);
use File::Spec;
use File::Find;
use File::Copy;

use Dpkg::Gettext;
use Dpkg::ErrorHandling;
use Dpkg::File;
use Dpkg::Path qw(find_command);
use Dpkg::Compression;
use Dpkg::Source::Archive;
use Dpkg::Source::Patch;
use Dpkg::Source::BinaryFiles;
use Dpkg::Exit qw(push_exit_handler pop_exit_handler);
use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time);
use Dpkg::Vendor qw(run_vendor_hook);
use Dpkg::Control;
use Dpkg::Changelog::Parse;
use Dpkg::OpenPGP;

use parent qw(Dpkg::Source::Package);

our $CURRENT_MINOR_VERSION = '0';

sub init_options {
    my $self = shift;
    $self-&gt;SUPER::init_options();
    $self-&gt;{options}{include_removal} //= 0;
    $self-&gt;{options}{include_timestamp} //= 0;
    $self-&gt;{options}{include_binaries} //= 0;
    $self-&gt;{options}{preparation} //= 1;
    $self-&gt;{options}{skip_patches} //= 0;
    $self-&gt;{options}{unapply_patches} //= 'auto';
    $self-&gt;{options}{skip_debianization} //= 0;
    $self-&gt;{options}{create_empty_orig} //= 0;
    $self-&gt;{options}{auto_commit} //= 0;
    $self-&gt;{options}{ignore_bad_version} //= 0;
}

my @module_cmdline = (
    {
        name =&gt; '--include-removal',
        help =&gt; N_('include removed files in the patch'),
        when =&gt; 'build',
    }, {
        name =&gt; '--include-timestamp',
        help =&gt; N_('include timestamp in the patch'),
        when =&gt; 'build',
    }, {
        name =&gt; '--include-binaries',
        help =&gt; N_('include binary files in the tarball'),
        when =&gt; 'build',
    }, {
        name =&gt; '--no-preparation',
        help =&gt; N_('do not prepare build tree by applying patches'),
        when =&gt; 'build',
    }, {
        name =&gt; '--no-unapply-patches',
        help =&gt; N_('do not unapply patches if previously applied'),
        when =&gt; 'build',
    }, {
        name =&gt; '--unapply-patches',
        help =&gt; N_('unapply patches if previously applied (default)'),
        when =&gt; 'build',
    }, {
        name =&gt; '--create-empty-orig',
        help =&gt; N_('create an empty original tarball if missing'),
        when =&gt; 'build',
    }, {
        name =&gt; '--abort-on-upstream-changes',
        help =&gt; N_('abort if generated diff has upstream files changes'),
        when =&gt; 'build',
    }, {
        name =&gt; '--auto-commit',
        help =&gt; N_('record generated patches, instead of aborting'),
        when =&gt; 'build',
    }, {
        name =&gt; '--skip-debianization',
        help =&gt; N_('do not extract debian tarball into upstream sources'),
        when =&gt; 'extract',
    }, {
        name =&gt; '--skip-patches',
        help =&gt; N_('do not apply patches at the end of the extraction'),
        when =&gt; 'extract',
    }
);

sub describe_cmdline_options {
    return @module_cmdline;
}

sub parse_cmdline_option {
    my ($self, $opt) = @_;
    if ($opt eq '--include-removal') {
        $self-&gt;{options}{include_removal} = 1;
        return 1;
    } elsif ($opt eq '--include-timestamp') {
        $self-&gt;{options}{include_timestamp} = 1;
        return 1;
    } elsif ($opt eq '--include-binaries') {
        $self-&gt;{options}{include_binaries} = 1;
        return 1;
    } elsif ($opt eq '--no-preparation') {
        $self-&gt;{options}{preparation} = 0;
        return 1;
    } elsif ($opt eq '--skip-patches') {
        $self-&gt;{options}{skip_patches} = 1;
        return 1;
    } elsif ($opt eq '--unapply-patches') {
        $self-&gt;{options}{unapply_patches} = 'yes';
        return 1;
    } elsif ($opt eq '--no-unapply-patches') {
        $self-&gt;{options}{unapply_patches} = 'no';
        return 1;
    } elsif ($opt eq '--skip-debianization') {
        $self-&gt;{options}{skip_debianization} = 1;
        return 1;
    } elsif ($opt eq '--create-empty-orig') {
        $self-&gt;{options}{create_empty_orig} = 1;
        return 1;
    } elsif ($opt eq '--abort-on-upstream-changes') {
        $self-&gt;{options}{auto_commit} = 0;
        return 1;
    } elsif ($opt eq '--auto-commit') {
        $self-&gt;{options}{auto_commit} = 1;
        return 1;
    } elsif ($opt eq '--ignore-bad-version') {
        $self-&gt;{options}{ignore_bad_version} = 1;
        return 1;
    }
    return 0;
}

sub do_extract {
    my ($self, $newdirectory) = @_;
    my $fields = $self-&gt;{fields};

    my $dscdir = $self-&gt;{basedir};

    my $basename = $self-&gt;get_basename();
    my $basenamerev = $self-&gt;get_basename(1);

    my ($tarfile, $debianfile, %addonfile, %seen);
    my ($tarsign, %addonsign);
    my $re_ext = compression_get_file_extension_regex();
    foreach my $file ($self-&gt;get_files()) {
        my $uncompressed = $file;
        $uncompressed =~ s/\.$re_ext$/.*/;
        $uncompressed =~ s/\.$re_ext\.asc$/.*.asc/;
        error(g_('duplicate files in %s source package: %s'), 'v2.0',
              $uncompressed) if $seen{$uncompressed};
        $seen{$uncompressed} = 1;
        if ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext$/) {
            $tarfile = $file;
        } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext\.asc$/) {
            $tarsign = $file;
        } elsif ($file =~ /^\Q$basename\E\.orig-([[:alnum:]-]+)\.tar\.$re_ext$/) {
            $addonfile{$1} = $file;
        } elsif ($file =~ /^\Q$basename\E\.orig-([[:alnum:]-]+)\.tar\.$re_ext\.asc$/) {
            $addonsign{$1} = $file;
        } elsif ($file =~ /^\Q$basenamerev\E\.debian\.tar\.$re_ext$/) {
            $debianfile = $file;
        } else {
            error(g_('unrecognized file for a %s source package: %s'),
            'v2.0', $file);
        }
    }

    unless ($tarfile and $debianfile) {
        error(g_('missing orig.tar or debian.tar file in v2.0 source package'));
    }
    if ($tarsign and $tarfile ne substr $tarsign, 0, -4) {
        error(g_('mismatched orig.tar %s for signature %s in source package'),
              $tarfile, $tarsign);
    }
    foreach my $name (keys %addonsign) {
        error(g_('missing addon orig.tar for signature %s in source package'),
              $addonsign{$name})
            if not exists $addonfile{$name};
        error(g_('mismatched addon orig.tar %s for signature %s in source package'),
              $addonfile{$name}, $addonsign{$name})
            if $addonfile{$name} ne substr $addonsign{$name}, 0, -4;
    }

    if ($self-&gt;{options}{no_overwrite_dir} and -e $newdirectory) {
        error(g_('unpack target exists: %s'), $newdirectory);
    } else {
        erasedir($newdirectory);
    }

    # Extract main tarball
    info(g_('unpacking %s'), $tarfile);
    my $tar = Dpkg::Source::Archive-&gt;new(filename =&gt; "$dscdir$tarfile");
    $tar-&gt;extract($newdirectory, no_fixperms =&gt; 1,
                  options =&gt; [ '--anchored', '--no-wildcards-match-slash',
                               '--exclude', '*/.pc', '--exclude', '.pc' ]);
    # The .pc exclusion is only needed for 3.0 (quilt) and to avoid
    # having an upstream tarball provide a directory with symlinks
    # that would be blindly followed when applying the patches

    # Extract additional orig tarballs
    foreach my $subdir (sort keys %addonfile) {
        my $file = $addonfile{$subdir};
        info(g_('unpacking %s'), $file);

        # If the pathname is an empty directory, just silently remove it, as
        # it might be part of a git repository, as a submodule for example.
        rmdir "$newdirectory/$subdir";
        if (-e "$newdirectory/$subdir") {
            warning(g_("required removal of '%s' installed by original tarball"),
                    $subdir);
            erasedir("$newdirectory/$subdir");
        }
        $tar = Dpkg::Source::Archive-&gt;new(filename =&gt; "$dscdir$file");
        $tar-&gt;extract("$newdirectory/$subdir", no_fixperms =&gt; 1);
    }

    # Stop here if debianization is not wanted
    return if $self-&gt;{options}{skip_debianization};

    # Extract debian tarball after removing the debian directory
    info(g_('unpacking %s'), $debianfile);
    erasedir("$newdirectory/debian");
    $tar = Dpkg::Source::Archive-&gt;new(filename =&gt; "$dscdir$debianfile");
    $tar-&gt;extract($newdirectory, in_place =&gt; 1);

    # Apply patches (in a separate method as it might be overridden)
    $self-&gt;apply_patches($newdirectory, usage =&gt; 'unpack')
        unless $self-&gt;{options}{skip_patches};
}

sub get_autopatch_name {
    return 'zz_debian-diff-auto';
}

sub _get_patches {
    my ($self, $dir, %opts) = @_;
    $opts{skip_auto} //= 0;
    my @patches;
    my $pd = "$dir/debian/patches";
    my $auto_patch = $self-&gt;get_autopatch_name();
    if (-d $pd) {
        opendir(my $dir_dh, $pd) or syserr(g_('cannot opendir %s'), $pd);
        foreach my $patch (sort readdir($dir_dh)) {
            # patches match same rules as run-parts
            next unless $patch =~ /^[\w-]+$/ and -f "$pd/$patch";
            next if $opts{skip_auto} and $patch eq $auto_patch;
            push @patches, $patch;
        }
        closedir($dir_dh);
    }
    return @patches;
}

sub apply_patches {
    my ($self, $dir, %opts) = @_;
    $opts{skip_auto} //= 0;
    my @patches = $self-&gt;_get_patches($dir, %opts);
    return unless scalar(@patches);
    my $applied = File::Spec-&gt;catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
    open(my $applied_fh, '&gt;', $applied)
        or syserr(g_('cannot write %s'), $applied);
    print { $applied_fh } "# During $opts{usage}\n";
    my $timestamp = fs_time($applied);
    foreach my $patch ($self-&gt;_get_patches($dir, %opts)) {
        my $path = File::Spec-&gt;catfile($dir, 'debian', 'patches', $patch);
        info(g_('applying %s'), $patch) unless $opts{skip_auto};
        my $patch_obj = Dpkg::Source::Patch-&gt;new(filename =&gt; $path);
        $patch_obj-&gt;apply($dir, force_timestamp =&gt; 1,
                          timestamp =&gt; $timestamp,
                          add_options =&gt; [ '-E' ]);
        print { $applied_fh } "$patch\n";
    }
    close($applied_fh);
}

sub unapply_patches {
    my ($self, $dir, %opts) = @_;
    my @patches = reverse($self-&gt;_get_patches($dir, %opts));
    return unless scalar(@patches);
    my $applied = File::Spec-&gt;catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
    my $timestamp = fs_time($applied);
    foreach my $patch (@patches) {
        my $path = File::Spec-&gt;catfile($dir, 'debian', 'patches', $patch);
        info(g_('unapplying %s'), $patch) unless $opts{quiet};
        my $patch_obj = Dpkg::Source::Patch-&gt;new(filename =&gt; $path);
        $patch_obj-&gt;apply($dir, force_timestamp =&gt; 1, verbose =&gt; 0,
                          timestamp =&gt; $timestamp,
                          add_options =&gt; [ '-E', '-R' ]);
    }
    unlink($applied);
}

sub _upstream_tarball_template {
    my $self = shift;
    my $ext = '{' . join(',',
        sort map {
            compression_get_property($_, 'file_ext')
        } compression_get_list()) . '}';
    return '../' . $self-&gt;get_basename() . ".orig.tar.$ext";
}

sub can_build {
    my ($self, $dir) = @_;
    return 1 if $self-&gt;find_original_tarballs(include_supplementary =&gt; 0);
    return 1 if $self-&gt;{options}{create_empty_orig} and
                $self-&gt;find_original_tarballs(include_main =&gt; 0);
    return (0, sprintf(g_('no upstream tarball found at %s'),
                       $self-&gt;_upstream_tarball_template()));
}

sub before_build {
    my ($self, $dir) = @_;
    $self-&gt;check_patches_applied($dir) if $self-&gt;{options}{preparation};
}

sub after_build {
    my ($self, $dir) = @_;
    my $applied = File::Spec-&gt;catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
    my $reason = '';
    if (-e $applied) {
        open(my $applied_fh, '&lt;', $applied)
            or syserr(g_('cannot read %s'), $applied);
        $reason = &lt;$applied_fh&gt;;
        close($applied_fh);
    }
    my $opt_unapply = $self-&gt;{options}{unapply_patches};
    if (($opt_unapply eq 'auto' and $reason =~ /^# During preparation/) or
        $opt_unapply eq 'yes') {
        $self-&gt;unapply_patches($dir);
    }
}

sub prepare_build {
    my ($self, $dir) = @_;
    $self-&gt;{diff_options} = {
        diff_ignore_regex =&gt; $self-&gt;{options}{diff_ignore_regex} .
                             '|(^|/)debian/patches/.dpkg-source-applied$',
        include_removal =&gt; $self-&gt;{options}{include_removal},
        include_timestamp =&gt; $self-&gt;{options}{include_timestamp},
        use_dev_null =&gt; 1,
    };
    push @{$self-&gt;{options}{tar_ignore}}, 'debian/patches/.dpkg-source-applied';
    $self-&gt;check_patches_applied($dir) if $self-&gt;{options}{preparation};
    if ($self-&gt;{options}{create_empty_orig} and
        not $self-&gt;find_original_tarballs(include_supplementary =&gt; 0))
    {
        # No main orig.tar, create a dummy one
        my $filename = $self-&gt;get_basename() . '.orig.tar.' .
                       $self-&gt;{options}{comp_ext};
        my $tar = Dpkg::Source::Archive-&gt;new(filename =&gt; $filename,
                                             compression_level =&gt; $self-&gt;{options}{comp_level});
        $tar-&gt;create();
        $tar-&gt;finish();
    }
}

sub check_patches_applied {
    my ($self, $dir) = @_;
    my $applied = File::Spec-&gt;catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
    unless (-e $applied) {
        info(g_('patches are not applied, applying them now'));
        $self-&gt;apply_patches($dir, usage =&gt; 'preparation');
    }
}

sub _generate_patch {
    my ($self, $dir, %opts) = @_;
    my ($dirname, $updir) = fileparse($dir);
    my $basedirname = $self-&gt;get_basename();
    $basedirname =~ s/_/-/;

    # Identify original tarballs
    my ($tarfile, %addonfile);
    my $comp_ext_regex = compression_get_file_extension_regex();
    my @origtarfiles;
    foreach my $file (sort $self-&gt;find_original_tarballs()) {
        if ($file =~ /\.orig\.tar\.$comp_ext_regex$/) {
            if (defined($tarfile)) {
                error(g_('several orig.tar files found (%s and %s) but only ' .
                         'one is allowed'), $tarfile, $file);
            }
            $tarfile = $file;
            push @origtarfiles, $file;
            $self-&gt;add_file($file);
            if (-e "$file.sig" and not -e "$file.asc") {
                openpgp_sig_to_asc("$file.sig", "$file.asc");
            }
            if (-e "$file.asc") {
                push @origtarfiles, "$file.asc";
                $self-&gt;add_file("$file.asc")
            }
        } elsif ($file =~ /\.orig-([[:alnum:]-]+)\.tar\.$comp_ext_regex$/) {
            $addonfile{$1} = $file;
            push @origtarfiles, $file;
            $self-&gt;add_file($file);
            if (-e "$file.sig" and not -e "$file.asc") {
                openpgp_sig_to_asc("$file.sig", "$file.asc");
            }
            if (-e "$file.asc") {
                push @origtarfiles, "$file.asc";
                $self-&gt;add_file("$file.asc");
            }
        }
    }

    error(g_('no upstream tarball found at %s'),
          $self-&gt;_upstream_tarball_template()) unless $tarfile;

    if ($opts{usage} eq 'build') {
        foreach my $origtarfile (@origtarfiles) {
            info(g_('building %s using existing %s'),
                 $self-&gt;{fields}{'Source'}, $origtarfile);
        }
    }

    # Unpack a second copy for comparison
    my $tmp = tempdir("$dirname.orig.XXXXXX", DIR =&gt; $updir);
    push_exit_handler(sub { erasedir($tmp) });

    # Extract main tarball
    my $tar = Dpkg::Source::Archive-&gt;new(filename =&gt; $tarfile);
    $tar-&gt;extract($tmp);

    # Extract additional orig tarballs
    foreach my $subdir (keys %addonfile) {
        my $file = $addonfile{$subdir};
        $tar = Dpkg::Source::Archive-&gt;new(filename =&gt; $file);
        $tar-&gt;extract("$tmp/$subdir");
    }

    # Copy over the debian directory
    erasedir("$tmp/debian");
    system('cp', '-a', '--', "$dir/debian", "$tmp/");
    subprocerr(g_('copy of the debian directory')) if $?;

    # Apply all patches except the last automatic one
    $opts{skip_auto} //= 0;
    $self-&gt;apply_patches($tmp, skip_auto =&gt; $opts{skip_auto}, usage =&gt; 'build');

    # Create a patch
    my ($difffh, $tmpdiff) = tempfile($self-&gt;get_basename(1) . '.diff.XXXXXX',
                                      TMPDIR =&gt; 1, UNLINK =&gt; 0);
    push_exit_handler(sub { unlink($tmpdiff) });
    my $diff = Dpkg::Source::Patch-&gt;new(filename =&gt; $tmpdiff,
                                        compression =&gt; 'none');
    $diff-&gt;create();
    if ($opts{header_from} and -e $opts{header_from}) {
        my $header_from = Dpkg::Source::Patch-&gt;new(
            filename =&gt; $opts{header_from});
        my $analysis = $header_from-&gt;analyze($dir, verbose =&gt; 0);
        $diff-&gt;set_header($analysis-&gt;{patchheader});
    } else {
        $diff-&gt;set_header($self-&gt;_get_patch_header($dir));
    }
    $diff-&gt;add_diff_directory($tmp, $dir, basedirname =&gt; $basedirname,
            %{$self-&gt;{diff_options}},
            handle_binary_func =&gt; $opts{handle_binary},
            order_from =&gt; $opts{order_from});
    error(g_('unrepresentable changes to source')) if not $diff-&gt;finish();

    if (-s $tmpdiff) {
        info(g_('local changes detected, the modified files are:'));
        my $analysis = $diff-&gt;analyze($dir, verbose =&gt; 0);
        foreach my $fn (sort keys %{$analysis-&gt;{filepatched}}) {
            print " $fn\n";
        }
    }

    # Remove the temporary directory
    erasedir($tmp);
    pop_exit_handler();
    pop_exit_handler();

    return $tmpdiff;
}

sub do_build {
    my ($self, $dir) = @_;
    my @argv = @{$self-&gt;{options}{ARGV}};
    if (scalar(@argv)) {
        usageerr(g_("-b takes only one parameter with format '%s'"),
                 $self-&gt;{fields}{'Format'});
    }
    $self-&gt;prepare_build($dir);

    my $include_binaries = $self-&gt;{options}{include_binaries};
    my @tar_ignore = map { "--exclude=$_" } @{$self-&gt;{options}{tar_ignore}};

    my $sourcepackage = $self-&gt;{fields}{'Source'};
    my $basenamerev = $self-&gt;get_basename(1);

    # Check if the debian directory contains unwanted binary files
    my $binaryfiles = Dpkg::Source::BinaryFiles-&gt;new($dir);

    $binaryfiles-&gt;detect_binary_files(
        exclude_globs =&gt; $self-&gt;{options}{tar_ignore},
        include_binaries =&gt; $include_binaries,
    );

    # Handle modified binary files detected by the auto-patch generation
    my $handle_binary = sub {
        my ($self, $old, $new, %opts) = @_;

        my $file = $opts{filename};
        $binaryfiles-&gt;new_binary_found($file);
        unless ($include_binaries or $binaryfiles-&gt;binary_is_allowed($file)) {
            errormsg(g_('cannot represent change to %s: %s'), $file,
                     g_('binary file contents changed'));
            errormsg(g_('add %s in debian/source/include-binaries if you want ' .
                        'to store the modified binary in the debian tarball'),
                     $file);
            $self-&gt;register_error();
        }
    };

    # Create a patch
    my $autopatch = File::Spec-&gt;catfile($dir, 'debian', 'patches',
                                        $self-&gt;get_autopatch_name());
    my $tmpdiff = $self-&gt;_generate_patch($dir, order_from =&gt; $autopatch,
                                        header_from =&gt; $autopatch,
                                        handle_binary =&gt; $handle_binary,
                                        skip_auto =&gt; $self-&gt;{options}{auto_commit},
                                        usage =&gt; 'build');
    unless (-z $tmpdiff or $self-&gt;{options}{auto_commit}) {
        info(g_('you can integrate the local changes with %s'),
             'dpkg-source --commit');
        error(g_('aborting due to unexpected upstream changes, see %s'),
              $tmpdiff);
    }
    push_exit_handler(sub { unlink($tmpdiff) });
    $binaryfiles-&gt;update_debian_source_include_binaries() if $include_binaries;

    # Install the diff as the new autopatch
    if ($self-&gt;{options}{auto_commit}) {
        make_path(File::Spec-&gt;catdir($dir, 'debian', 'patches'));
        $autopatch = $self-&gt;register_patch($dir, $tmpdiff,
                                           $self-&gt;get_autopatch_name());
        info(g_('local changes have been recorded in a new patch: %s'),
             $autopatch) if -e $autopatch;
        rmdir(File::Spec-&gt;catdir($dir, 'debian', 'patches')); # No check on purpose
    }
    unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff);
    pop_exit_handler();

    # Create the debian.tar
    my $debianfile = "$basenamerev.debian.tar." . $self-&gt;{options}{comp_ext};
    info(g_('building %s in %s'), $sourcepackage, $debianfile);
    my $tar = Dpkg::Source::Archive-&gt;new(filename =&gt; $debianfile,
                                         compression_level =&gt; $self-&gt;{options}{comp_level});
    $tar-&gt;create(options =&gt; \@tar_ignore, chdir =&gt; $dir);
    $tar-&gt;add_directory('debian');
    foreach my $binary ($binaryfiles-&gt;get_seen_binaries()) {
        $tar-&gt;add_file($binary) unless $binary =~ m{^debian/};
    }
    $tar-&gt;finish();

    $self-&gt;add_file($debianfile);
}

sub _get_patch_header {
    my ($self, $dir) = @_;
    my $ph = File::Spec-&gt;catfile($dir, 'debian', 'source', 'local-patch-header');
    unless (-f $ph) {
        $ph = File::Spec-&gt;catfile($dir, 'debian', 'source', 'patch-header');
    }
    if (-f $ph) {
        return file_slurp($ph);
    }
    my $ch_info = changelog_parse(offset =&gt; 0, count =&gt; 1,
        file =&gt; File::Spec-&gt;catfile($dir, 'debian', 'changelog'));
    return '' if not defined $ch_info;
    my $header = Dpkg::Control-&gt;new(type =&gt; CTRL_UNKNOWN);
    $header-&gt;{'Description'} = "&lt;short summary of the patch&gt;\n";
    $header-&gt;{'Description'} .=
"TODO: Put a short summary on the line above and replace this paragraph
with a longer explanation of this change. Complete the meta-information
with other relevant fields (see below for details). To make it easier, the
information below has been extracted from the changelog. Adjust it or drop
it.\n";
    $header-&gt;{'Description'} .= $ch_info-&gt;{'Changes'} . "\n";
    $header-&gt;{'Author'} = $ch_info-&gt;{'Maintainer'};
    my $yyyy_mm_dd = POSIX::strftime('%Y-%m-%d', gmtime);

    my $text;
    $text = "$header";
    run_vendor_hook('extend-patch-header', \$text, $ch_info);
    $text .= "\n---
The information above should follow the Patch Tagging Guidelines, please
checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
are templates for supplementary fields that you might want to add:

Origin: &lt;vendor|upstream|other&gt;, &lt;url of original patch&gt;
Bug: &lt;url in upstream bugtracker&gt;
Bug-Debian: https://bugs.debian.org/&lt;bugnumber&gt;
Bug-Ubuntu: https://launchpad.net/bugs/&lt;bugnumber&gt;
Forwarded: &lt;no|not-needed|url proving that it has been forwarded&gt;
Reviewed-By: &lt;name and email of someone who approved the patch&gt;
Last-Update: $yyyy_mm_dd\n\n";
    return $text;
}

sub register_patch {
    my ($self, $dir, $patch_file, $patch_name) = @_;
    my $patch = File::Spec-&gt;catfile($dir, 'debian', 'patches', $patch_name);
    if (-s $patch_file) {
        copy($patch_file, $patch)
            or syserr(g_('failed to copy %s to %s'), $patch_file, $patch);
        chmod_if_needed(0666 &amp; ~ umask(), $patch)
            or syserr(g_("unable to change permission of '%s'"), $patch);
        my $applied = File::Spec-&gt;catfile($dir, 'debian', 'patches', '.dpkg-source-applied');
        open(my $applied_fh, '&gt;&gt;', $applied)
            or syserr(g_('cannot write %s'), $applied);
        print { $applied_fh } "$patch\n";
        close($applied_fh) or syserr(g_('cannot close %s'), $applied);
    } elsif (-e $patch) {
        unlink($patch) or syserr(g_('cannot remove %s'), $patch);
    }
    return $patch;
}

sub _is_bad_patch_name {
    my ($dir, $patch_name) = @_;

    return 1 if not defined($patch_name);
    return 1 if not length($patch_name);

    my $patch = File::Spec-&gt;catfile($dir, 'debian', 'patches', $patch_name);
    if (-e $patch) {
        warning(g_('cannot register changes in %s, this patch already exists'),
                $patch);
        return 1;
    }
    return 0;
}

sub do_commit {
    my ($self, $dir) = @_;
    my ($patch_name, $tmpdiff) = @{$self-&gt;{options}{ARGV}};

    $self-&gt;prepare_build($dir);

    # Try to fix up a broken relative filename for the patch
    if ($tmpdiff and not -e $tmpdiff) {
        $tmpdiff = File::Spec-&gt;catfile($dir, $tmpdiff)
            unless File::Spec-&gt;file_name_is_absolute($tmpdiff);
        error(g_("patch file '%s' doesn't exist"), $tmpdiff) if not -e $tmpdiff;
    }

    my $binaryfiles = Dpkg::Source::BinaryFiles-&gt;new($dir);
    my $handle_binary = sub {
        my ($self, $old, $new, %opts) = @_;
        my $fn = File::Spec-&gt;abs2rel($new, $dir);
        $binaryfiles-&gt;new_binary_found($fn);
    };

    unless ($tmpdiff) {
        $tmpdiff = $self-&gt;_generate_patch($dir, handle_binary =&gt; $handle_binary,
                                         usage =&gt; 'commit');
        $binaryfiles-&gt;update_debian_source_include_binaries();
    }
    push_exit_handler(sub { unlink($tmpdiff) });
    unless (-s $tmpdiff) {
        unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff);
        info(g_('there are no local changes to record'));
        return;
    }
    while (_is_bad_patch_name($dir, $patch_name)) {
        # Ask the patch name interactively
        print g_('Enter the desired patch name: ');
        $patch_name = &lt;STDIN&gt;;
        if (not defined $patch_name) {
            error(g_('no patch name given; cannot proceed'));
        }
        chomp $patch_name;
        $patch_name =~ s/\s+/-/g;
        $patch_name =~ s/\///g;
    }
    make_path(File::Spec-&gt;catdir($dir, 'debian', 'patches'));
    my $patch = $self-&gt;register_patch($dir, $tmpdiff, $patch_name);
    my @editors = ('sensible-editor', $ENV{VISUAL}, $ENV{EDITOR}, 'vi');
    my $editor = first { find_command($_) } @editors;
    if (not $editor) {
        error(g_('cannot find an editor'));
    }
    system($editor, $patch);
    subprocerr($editor) if $?;
    unlink($tmpdiff) or syserr(g_('cannot remove %s'), $tmpdiff);
    pop_exit_handler();
    info(g_('local changes have been recorded in a new patch: %s'), $patch);
}

1;
</pre></body></html>