#!/usr/bin/perl
#
# backport -- Backport a Debian package automatically.
#
# Written by Russ Allbery <eagle@eyrie.org>
# Copyright 2015 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2008, 2009, 2010, 2011, 2013
#     The Board of Trustees of the Leland Stanford Junior University
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.

##############################################################################
# Modules and declarations
##############################################################################

use 5.006;
use strict;
use warnings;

use File::Basename qw(basename);
use Getopt::Long qw(GetOptions);

# Avoid a dependency on List::MoreUtils.
## no critic (BuiltinFunctions::ProhibitBooleanGrep)

# Refactoring work yet to be done.
## no critic (ControlStructures::ProhibitCascadingIfElse)
## no critic (InputOutput::RequireBriefOpen)
## no critic (Subroutines::ProhibitExcessComplexity)

# Get the script version number from CVS.
our $ID = q$Id: backport,v 1.32 2015/08/17 00:48:39 eagle Exp $;

# The supported backporting version schemes.  This is a hash of target name
# (suitable for the -t option) to version suffix pattern.  Currently, the
# pattern is a constant.  Later versions of this script may support setting
# things like the target Debian release number.  The suffix pattern should not
# contain the leading ~; that will be added automatically.
our %SUFFIX = (
    bpo      => 'bpo',
    eyrie    => 'ebp',
    stanford => 'sbp',
);

# The mapping from known distribution targets to version numbers.
our %VERSION = (
    'etch-backports'    => '40',
    etch                => '40',
    'lenny-backports'   => '50',
    lenny               => '50',
    oldstable           => '60',
    'squeeze-backports' => '60',
    squeeze             => '60',
    'wheezy-backports'  => '70',
    wheezy              => '70',
    'jessie-backports'  => '8',
    jessie              => '8',
    stable              => '8',
);

##############################################################################
# Utility functions
##############################################################################

# Add a change to the existing changelog entry with dch.  More than one
# message may be given in one call, in which case each is added as a separate
# changelog entry.
#
# @messages - The messages to add
#
# Returns: undef
#  Throws: Text exception on dch failure
sub dch {
    my (@messages) = @_;
    for my $message (@messages) {
        system('dch', '-a', $message) == 0
          or die "dch -a '$message' failed\n";
    }
    return;
}

# Check the debian/control file to see if the backporter is already a
# maintainer or uploader, and if not, add them to Uploaders.  Extract the
# backporter from debian/changelog (requiring that this function be called
# after the initial changelog entry is written) so that we don't have to
# reproduce the logic from dch.
#
# Returns: undef
#  Throws: Text exception on failure
sub fix_uploaders {
    my $maintainer;
    open(my $changelog, q{-|}, 'dpkg-parsechangelog')
      or die "Cannot run dpkg-parsechangelog: $!\n";
  CHANGELOG:
    while (defined(my $line = <$changelog>)) {
        if ($line =~ m{ \A Maintainer: \s+ (.*) \z}xms) {
            $maintainer = $1;
            last CHANGELOG;
        }
    }
    close($changelog) or die "Cannot close dpkg-parsechangelog: $!\n";
    return if !defined($maintainer);
    $maintainer =~ s{ \s+ \z }{}xms;

    # Scan the existing control file and see if the maintainer already occurs
    # in Maintainer or Uploaders.  We have to deal with line continuation in
    # the Uploaders field, which makes this a bit complicated.  I should
    # probably use one of the parsing libraries, but then I have an extra
    # dependency.
    my (@control, $found, $inuploaders);
    open(my $control, '<', 'debian/control')
      or die "Cannot open debian/control: $!\n";
  CONTROL:
    while (defined(my $line = <$control>)) {
        last CONTROL if $line eq "\n";
        push(@control, $line);

        # Check if this is a line we're interested in.
        if ($line =~ m{ \A (?:Maintainer|Uploaders): \s* (.*) \n \z }xmsi) {
            my @ids = split(m{ \s*,\s* }xms, $1);
            $inuploaders = 1;
            if (grep { $_ eq $maintainer } @ids) {
                $found = 1;
                last CONTROL;
            }
        } elsif ($inuploaders && $line =~ m{ \A \s }xms) {
            $line =~ s{ \A \s+ }{}xms;
            $line =~ s{ \s+ \z }{}xms;
            my @ids = split(m{ \s*,\s* }xms, $line);
            if (grep { $_ eq $maintainer } @ids) {
                $found = 1;
                last CONTROL;
            }
        } else {
            $inuploaders = 0;
        }
    }

    # If the backporter wasn't found, we need to add them to Uploaders.  We
    # want to add them to the end of Uploaders, including any continuation
    # lines, and add a new continuation line if the line was too long.  If
    # there is no Uploaders field, add a new one.
    if (!$found) {
        my $done;
        open(my $new, '>', 'debian/control.new')
          or die "Cannot create debian/control.new: $!\n";
        for my $i (0 .. $#control) {
            if (!$done && $control[$i] =~ m{ \A Uploaders: }xmsi) {
                my $j = $i + 1;
                while ($control[$j] && $control[$j] =~ m{ \A \s }xms) {
                    $j++;
                }
                $j--;
                chomp $control[$j];
                if (length($control[$j]) + length($maintainer) > 72) {
                    $control[$j] .= ",\n $maintainer\n";
                } else {
                    $control[$j] .= ", $maintainer\n";
                }
                $done = 1;
            }
            print {$new} $control[$i]
              or die "Cannot write to debian/control.new: $!\n";
        }
        if (!$done) {
            print {$new} "Uploaders: $maintainer\n"
              or die "Cannot write to debian/control.new: $!\n";
        }
        print {$new} "\n", <$control>
          or die "Cannot write to debian/control.new: $!\n";
        close($control)
          or die "Cannot close debian/control: $!\n";
        close($new)
          or die "Cannot flush debian/control.new: $!\n";
        rename('debian/control.new', 'debian/control')
          or die "Cannot rename debian/control.new to debian/control: $!\n";
        dch('Add myself to Uploaders.');
    }
    return;
}

# Given the path to a *.dsc file, determine the source version from that file.
# We need to determine this from the *.dsc file rather than the file name so
# that we can include the epoch.
#
# $dsc - Path to *.dsc file
#
# Returns: Version of the source package
#  Throws: Text exception on I/O or parse failure
sub source_version {
    my ($dsc) = @_;
    my $version;
    open(my $file, '<', $dsc)
      or die "Unable to open $dsc file for version: $!\n";
  DSC:
    while (defined(my $line = <$file>)) {
        if ($line =~ m{ \A Version: \s+ (\S+) \n \z}xms) {
            $version = $1;
            last DSC;
        }
    }
    close($file) or die "Cannot close $dsc: $!\n";
    if (!defined($version)) {
        die "Unable to parse $dsc for version\n";
    }
    return $version;
}

# Determine the maximum urgency of the changes that are included in this
# backport (or just the most recent change if we don't have information
# about the previous change in the target distribution).
#
# $last - Version number at which to stop searching (optional)
#
# Returns: Highest urgency of changes found
#  Throws: Text exception on I/O failure
sub urgency {
    my ($last_version) = @_;
    my $rank = 0;
    my %ranking = map { $_ => $rank++ } qw(low medium high emergency critical);
    my $urgency = 'low';

    # Determine the arguments for dpkg-parsechangelog.
    my @version = defined($last_version) ? ("-v$last_version") : ();

    # Run dpkg-parsechangelog and analyze the results.  We replace the current
    # urgency with a new one if the ranking of the current urgency is higher.
    open(my $changelog, q{-|}, 'dpkg-parsechangelog', @version)
      or die "Cannot run dpkg-parsechangelog: $!\n";
  CHANGELOG:
    while (defined(my $line = <$changelog>)) {
        if ($line =~ m{ \A Urgency: \s* (\S+) }xms) {
            my $current = lc($1);
            if ($ranking{$current} > $ranking{$urgency}) {
                $urgency = $current;
            }
        }
    }
    close($changelog) or die "Cannot close dpkg-parsechangelog: $!\n";
    return $urgency;
}

##############################################################################
# Special transforms
##############################################################################

# Perform standard changes required for building a package under etch that can
# be safely automated.  Mostly this involves correcting library dependencies.
#
# Returns: undef
#  Throws: Text exception on any failure
sub backport_etch {
    my ($changed, $contents, $new);
    open(my $control, '<', 'debian/control')
      or die "Cannot open debian/control: $!\n";
    while (defined(my $line = <$control>)) {
        my $changing;

        # Correct libremctl-dev build dependency for a bug in etch.
        if ($line =~ s{libremctl-dev,}{libremctl-dev, libremctl1}xms) {
            $changing = 1;
            dch(    'Adjust libremctl build dependency to work around a bug in'
                  . ' the etch version.');
        }

        # etch had libcurl3 instead of libcurl4.
        if ($line =~ s{libcurl4-}{libcurl3-}xms) {
            $changing = 1;
            dch('Build against libcurl3 instead of libcurl4.');
        }

        # etch had libxerces27-dev instead of libxerces-c2-dev.
        if (s{libxerces-c2-dev,}{libxerces27-dev,}xms) {
            $changing = 1;
            dch('Build against libxerces27-dev instead of libxerces-c2-dev.');
        }

        # If we've already started a new file, output to it.  Otherwise,
        # accumulate the contents of control in memory.
        if ($changed) {
            print {$new} $line
              or die "Cannot write to debian/control.new: $!\n";
        } else {
            $contents .= $_;
        }

        # If this is the first change we've made, start the new file.
        if ($changing && !$changed) {
            open($new, '>', 'debian/control.new')
              or die "Cannot create debian/control.new: $!\n";
            print {$new} $contents
              or die "Cannot write to debian/control.new: $!\n";
            $changed = 1;
        }
    }
    close($control) or die "Cannot close debian/control: $!\n";
    if ($changed) {
        close($new) or die "Cannot flush debian/control.new: $!\n";
        rename('debian/control.new', 'debian/control')
          or die "Cannot rename debian/control.new to debian/control: $!\n";
    }
    return;
}

# Perform standard changes required for building a package under lenny that
# can be safely automated.
#
# Returns: undef
#  Throws: Text exception on any failure
sub backport_lenny {
    my ($changed, $contents, %changes, $new);
    open(my $control, '<', 'debian/control')
      or die "Cannot open debian/control: $!\n";
    while (defined(my $line = <$control>)) {
        my $changing;

        # Convert possibly-versioned build dependencies on libxerces-c-dev to
        # a dependency on libxerces-c2-dev.
        ## no critic (RegularExpressions::ProhibitEscapedMetacharacters)
        if (
            s{ libxerces-c-dev\b (?: \s* [(] [^\)]+ [)] )? }
             {libxerces-c2-dev}xms
          )
        {
            $changing = 1;
            if (!$changes{xerces}) {
                dch(    'Build against libxerces-c2-dev instead of'
                      . ' libxerces-c-dev.');
            }
            $changes{xerces} = 1;
        }
        ## use critic

        # If we've already started a new file, output to it.  Otherwise,
        # accumulate the contents of control in memory.
        if ($changed) {
            print {$new} $line
              or die "Cannot write to debian/control.new: $!\n";
        } else {
            $contents .= $_;
        }

        # If this is the first change we've made, start the new file.
        if ($changing && !$changed) {
            open($new, '>', 'debian/control.new')
              or die "Cannot create debian/control.new: $!\n";
            print {$new} $contents
              or die "Cannot write to debian/control.new: $!\n";
            $changed = 1;
        }
    }
    close($control) or die "Cannot close debian/control: $!\n";
    if ($changed) {
        close($new) or die "Cannot flush debian/control.new: $!\n";
        rename('debian/control.new', 'debian/control')
          or die "Cannot rename debian/control.new to debian/control: $!\n";
    }
    return;
}

# No supported special transformations for other distributions yet.
sub backport_squeeze { }
sub backport_wheezy  { }
sub backport_jessie  { }

##############################################################################
# Implementation
##############################################################################

# The core of the work.  Parse the command-line options and do the appropriate
# thing.  This code badly needs to be refactored to be more data-driven.
#
# @args - Command-line arguments
#
# Returns: undef
#  Throws: Text exception on any failure
sub backport {
    my $fullpath = $0;
    local $0 = basename($0);

    # Parse command-line options.
    my (
        $architecture, $binary, $chroot,       $dist,
        $entry,        $help,   $last_version, $prepare,
        $suffix,       $target, $upstream,     $version
    );
    Getopt::Long::config('bundling');
    GetOptions(
        'A|architecture' => \$architecture,
        'a|add-upstream' => \$upstream,
        'b|binary'       => \$binary,
        'c|chroot=s'     => \$chroot,
        'd|dist=s'       => \$dist,
        'e|entry=s'      => \$entry,
        'h|help'         => \$help,
        'l|last=s'       => \$last_version,
        'p|prepare'      => \$prepare,
        's|suffix=s'     => \$suffix,
        't|target=s'     => \$target,
        'v|version'      => \$version
    ) or exit 1;
    if ($help) {
        print "Feeding myself to perldoc, please wait....\n"
          or die "Cannot write to standard output: $!\n";
        exec('perldoc', '-t', $fullpath)
          or die "Cannot exec perldoc -t $fullpath: $!\n";
    } elsif ($version) {
        my $output = join(q{ }, (split(q{ }, $ID))[1 .. 3]);
        $output =~ s{ ,v \b }{}xms;
        $output =~ s{ (\S+) \z }{($1)}xms;
        $output =~ tr{/}{-};
        print $output, "\n"
          or die "Cannot write to standard output: $!\n";
        exit(0);
    }
    $target ||= 'bpo';
    if (!$SUFFIX{$target}) {
        die "Unknown target $target\n";
    }
    if ($target eq 'bpo') {
        if (!defined($last_version)) {
            die "Must specify previous version for backports target\n";
        }
        $dist ||= 'jessie-backports';
    } else {
        $dist ||= 'stable';
    }
    if (!defined($chroot)) {
        if ($dist =~ m{etch}xms) {
            $chroot = 'base-etch';
        } elsif ($dist =~ m{lenny}xms) {
            $chroot = 'base-lenny';
        } elsif ($dist =~ m{squeeze}xms) {
            $chroot = 'base-squeeze';
        } elsif ($dist eq 'oldstable' or $dist =~ m{wheezy}xms) {
            $chroot = 'base-wheezy';
        } elsif ($dist eq 'stable' or $dist =~ m{jessie}xms) {
            $chroot = 'base-jessie';
        } else {
            $chroot = 'base-jessie';
        }
    }
    if (!defined($suffix)) {
        if (!$VERSION{$dist}) {
            die "Cannot determine version for distribution $dist\n";
        }
        $suffix = $SUFFIX{$target} . $VERSION{$dist} . '+1';
    }
    if (@ARGV == 0) {
        die "No source package *.dsc file specified\n";
    } elsif (@ARGV > 1) {
        die "Too many arguments specified\n";
    }
    my ($dsc) = @ARGV;

    # Now, work out a few additional variables we'll need.
    my $dir;
    if ($dsc =~ m{ \A ( [^_]* _ .*? ) (?: -[^-]* )? [.] dsc \z}xms) {
        $dir = $1;
    } else {
        $dir = $dsc;
    }
    $dir =~ tr{_}{-};
    $dir =~ s{ [.] dsc \z }{}xms;
    my $package;
    if ($dsc =~ m{ \A (.*) _ }xms) {
        $package = $1;
    } else {
        die "Unable to parse *.dsc file name for package name\n";
    }
    $version = source_version($dsc);
    my ($revision) = ($version =~ m{ - ([^-]+) \z}xms);
    $version .= q{~} . $suffix;

    # Do the actual work.
    system('dpkg-source', '-x', $dsc) == 0
      or die "dpkg-source failed\n";
    chdir($dir) or die "Cannot chdir to $dir: $!\n";
    my $message = 'Backport to ';
    if ($dist eq 'jessie-backports' || $dist eq 'jessie') {
        $message .= 'stable.';
    } elsif ($dist eq 'wheezy-backports' || $dist eq 'wheezy') {
        $message .= 'oldstable.';
    } else {
        $message .= "$dist.";
    }
    system('dch', '-v', $version, '--force-distribution', '-D', $dist, '-b',
        '-u', urgency($last_version), $message) == 0
      or die "dch failed\n";
    if ($entry) {
        dch($entry);
    }
    fix_uploaders;
    if ($dist =~ m{etch}xms) {
        backport_etch;
    } elsif ($dist =~ m{lenny}xms) {
        backport_lenny;
    } elsif ($dist =~ m{squeeze}xms) {
        backport_squeeze;
    } elsif ($dist eq 'oldstable' or $dist =~ m{wheezy}xms) {
        backport_wheezy;
    } elsif ($dist eq 'stable' or $dist =~ m{jessie}xms) {
        backport_jessie;
    } else {
        backport_jessie;
    }
    my @options = qw(-d);
    if (defined($last_version)) {
        push(@options, "-v$last_version");
    }
    if ($upstream || (defined($revision) && $revision eq '1')) {
        push(@options, '-sa');
    }
    if ($binary) {
        push(@options, '-B');
    }
    if ($architecture) {
        push(@options, '--architecture', $architecture);
    }
    @options = ('--debbuildopts', join(q{ }, @options));
    @options = (
        qw(--buildresult .. --pbuilder cowbuilder),
        @options,
        qw(-- --basepath),
        "/var/cache/pbuilder/$chroot.cow",
    );
    if ($dist =~ m{etch}xms) {
        push(@options, '--debian-etch-workaround');
    }
    if ($prepare) {
        print "Backport prepared in $dir.  To build, run:\n\n"
          or die "Cannot write to standard output: $!\n";
        print "  pdebuild @options\n\n"
          or die "Cannot write to standard output: $!\n";
    } else {
        print "Running pdebuild @options\n"
          or die "Cannot write to standard output: $!\n";
        system('pdebuild', @options) == 0
          or die "pdebuild failed\n";
        my $shortversion = $version;
        $shortversion =~ s{ \A \d+: }{}xms;
        if (-f "../${package}_${shortversion}_source.changes") {
            unlink("../${package}_${shortversion}_source.changes")
              or die "Cannot delete *_source.changes file: $!\n";
        }
    }
    return;
}

# Automatically flush standard output.
STDOUT->autoflush(1);

# Do the work.
backport();
exit(0);
__END__

##############################################################################
# Documentation
##############################################################################

=for stopwords
Allbery Backport Uploaders -abhpv backport backported backporting backports
dpkg-buildpackage changelog chroots cowbuilder dpkg dsc filename pdebuild
subdirectory urgencies wheezy-backports backports.debian.org chroot
jessie-backports

=head1 NAME

backport - Backport a Debian package automatically

=head1 SYNOPSIS

B<backport> [B<-abhpv>] [B<-c> I<chroot>] [B<-d> I<dist>] [B<-e> I<entry>]
    [B<-l> I<version>] [B<-s> I<suffix>] [B<-t> I<target>] I<dsc>

=head1 DESCRIPTION

B<backport> automates some of the tedium of backporting a Debian package
to stable.  Given the path to a *.dsc file, it unpacks the source package,
adds a changelog entry for the backport with an appropriate version
number, fixes build-dependencies that can be handled automatically, and
builds the package using B<pdebuild> and B<cowbuilder>.

By default, B<backport> prepares backports for backports.debian.org, using
its version number convention.  In this case, the B<-l> option, giving the
version number of the previous backport or the current stable version, is
mandatory.  Other backport targets may be specified with the B<-t> option.
The I<dist> (target distribution in the changelog) and I<suffix> (version
number suffix to append) are set automatically based on the I<target> but
can be overridden as needed.

B<backport> adds a F<debian/changelog> entry with the text C<Backport to
I<dist>.> plus any specific changelog entries for other significant
changes it makes.  The invoking user will be added to Uploaders in
F<debian/control> unless they are already listed in Maintainer or
Uploaders.  The urgency of the changelog entry will be the maximum of the
urgencies of the changelog entries for the backported package between the
version specified with B<-l> and the current version, or the urgency of
the most recent change if B<-l> was not given.

The *.dsc file given on the command line must be named according to the
normal Debian source package naming convention
(I<package>_I<version>.dsc), since it is parsed for package and version
information.  If it is not named appropriately, the script will fail.

=head1 OPTIONS

=over 4

=item B<-a>, B<--add-upstream>

Include the upstream *.orig.tar.gz file in the *.changes file and hence in
the upload.  This is necessary the first time a backport of a particular
package is uploaded to an archive.  If this option is not given, the
upstream tarball is included if and only if the original Debian revision
(before backporting) is C<1>.

=item B<-b>, B<--binary>

Do a binary-only build, meaning that neither source nor
architecture-independent binary package files will be included in the
build.  This is equivalent to the B<-B> option to B<dpkg-buildpackage> and
implemented by passing that option through.

=item B<-c> I<chroot>, B<--chroot>=I<chroot>

Use the specified chroot instead of the default chroot of C<base-jessie>
(or C<base-wheezy> if the distribution is C<oldstable> or contains
C<wheezy>, C<base-squeeze> if the distribution contains C<squeeze>,
C<base-lenny> if the distribution contains C<lenny>, or C<base-etch> if
the distribution contains C<etch>).  All chroots must be in
F</var/cache/pbuilder> and end with C<.cow>.  This option controls the
filename before C<.cow>.  In other words, the default chroot is
F</var/cache/pbuilder/base-jessie.cow>, and passing C<-c ebo> would use
F</var/cache/pbuilder/ebo.cow> instead.

=item B<-d> I<dist>, B<--dist>=I<dist>

The target distribution for the F<debian/changelog> entry.  By default,
this is C<jessie-backports> for a target of C<bpo> (the default), and
C<stable> for any other target.  The target distribution is used to choose
the version number suffix for the backported package.

=item B<-e> I<entry>, B<--entry>=I<entry>

Add an additional changelog entry I<entry> after the note that this is a
backport but before any information about changes made by this script.
This is suitable, for instance, for noting that the backport is a security
fix.

=item B<-h>, B<--help>

Print out this documentation (which is done simply by feeding the script
to C<perldoc -t>).

=item B<-l> I<version>, B<--last>=I<version>

Specifies the previous stable or backported version.  If this option is
given, the changelog in the *.changes file will include all changelog
entries back to that version (by using the B<-v> B<dpkg-buildpackage>
option).  If it is not given, only the most recent changelog entry (the
one for the backport) will be included.  This option is required for a
target of C<bpo> (backports.debian.org, the default).

=item B<-p>, B<--prepare>

Do not do the build.  Instead, prepare the backport, making required
modifications to F<debian/control> and F<debian/changelog>, and then leave
the prepared backport in a subdirectory, printing out the command to run
to build the package.  This is useful for testing or if additional
modifications will be needed after the automated work done by B<backport>.

=item B<-s> I<suffix>, B<--suffix>=I<suffix>

The suffix appended to the version number of the package (after a C<~>).
The default varies based on the selected target and target distribution.
For C<bpo> and C<jessie-backports> (the default), it will be C<bpo8+1>.
If the distribution isn't one that B<backport> recognizes, you may need to
specify the version suffix manually.

=item B<-t> I<target>, B<--target>=I<target>

The backporting target, used to set other variables, primarily the version
suffix appended to the package version.  Currently supported targets are
C<bpo>, C<eyrie>, and C<stanford>.  C<bpo> is the default.

=item B<-v>, B<--version>

Print out the version of B<backport> and exit.

=back

=head1 NOTES

This script avoids some tedium, but it should not be used blindly.  The
results are not guaranteed to work, and some packages have subtle
compatibility issues or other backporting issues that it cannot handle
automatically.  The results of a backport should always be tested before
being uploaded to backports.debian.org or used in a production
environment.

=head1 BUGS

Currently, most of the interesting settings (such as the target
distribution for the backport, or the path to the B<cowbuilder> base
chroot) are hard-coded in this script, and it only does backports to
C<jessie>, C<wheezy>, C<squeeze>, C<lenny>, or C<etch>.  This could be
improved in later versions to allow more configuration.

B<pdebuild> and B<cowbuilder> are used unconditionally.

=head1 SEE ALSO

cowbuilder(8), dpkg-buildpackage(1), pdebuild(1)

The backports.debian.org contributor documentation, available at
L<http://backports.debian.org/Instructions/>.

=head1 AUTHOR

Russ Allbery <eagle@eyrie.org>

=head1 COPYRIGHT AND LICENSE

Copyright 2015 Russ Allbery <eagle@eyrie.org>

Copyright 2007, 2008, 2009, 2010, 2011, 2013 The Board of Trustees of the
Leland Stanford Junior University

This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.

=cut