dpkg/scripts/Dpkg/Source/Package/V3/quilt.pm

# Copyright © 2008 Raphaël Hertzog <hertzog@debian.org>
#
# 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 <http://www.gnu.org/licenses/>.

package Dpkg::Source::Package::V3::quilt;

use strict;
use warnings;

# Based on wig&pen implementation
use base 'Dpkg::Source::Package::V2';

use Dpkg;
use Dpkg::Gettext;
use Dpkg::ErrorHandling;
use Dpkg::Source::Patch;
use Dpkg::IPC;
use Dpkg::Vendor qw(get_current_vendor run_vendor_hook);
use Dpkg::Control;
use Dpkg::Changelog::Parse;

use POSIX;
use File::Basename;
use File::Spec;
use File::Path;

our $CURRENT_MINOR_VERSION = "0";

sub init_options {
    my ($self) = @_;
    $self->SUPER::init_options();
    # By default use quilt, unless it's not available
    $self->{'options'}{'without_quilt'} = (-x "/usr/bin/quilt") ? 0 : 1
        unless exists $self->{'options'}{'without_quilt'};
}

sub parse_cmdline_option {
    my ($self, $opt) = @_;
    return 1 if $self->SUPER::parse_cmdline_option($opt);
    if ($opt =~ /^--without-quilt$/) {
        $self->{'options'}{'without_quilt'} = 1;
        return 1;
    }
    return 0;
}

sub get_autopatch_name {
    my ($self) = @_;
    return "debian-changes-" . $self->{'fields'}{'Version'};
}

sub get_series_file {
    my ($self, $dir) = @_;
    my $pd = File::Spec->catdir($dir, "debian", "patches");
    my $vendor = lc(get_current_vendor() || "debian");
    foreach (File::Spec->catfile($pd, "$vendor.series"),
             File::Spec->catfile($pd, "series")) {
        return $_ if -e $_;
    }
    return undef;
}

sub get_patches {
    my ($self, $dir, $skip_auto) = @_;
    my @patches;
    my $auto_patch = $self->get_autopatch_name();
    my $series = $self->get_series_file($dir);
    if (defined($series)) {
        open(SERIES, "<" , $series) || syserr(_g("cannot read %s"), $series);
        while(defined($_ = <SERIES>)) {
            chomp; s/^\s+//; s/\s+$//; # Strip leading/trailing spaces
            s/(^|\s+)#.*$//; # Strip comment
            next unless $_;
            if (/^(\S+)\s+(.*)$/) {
                $_ = $1;
                if ($2 ne '-p1') {
                    warning(_g("the series file (%s) contains unsupported " .
                               "options ('%s', line %s), dpkg-source might " .
                               "fail when applying patches."),
                            $series, $2, $.) unless $skip_auto;
                }
            }
            next if $skip_auto and $_ eq $auto_patch;
            push @patches, $_;
        }
        close(SERIES);
    }
    return @patches;
}

sub run_quilt {
    my ($self, $dir, $params, %more_opts) = @_;
    $params = [ $params ] unless ref($params) eq "ARRAY";
    my $absdir = $dir;
    unless (File::Spec->file_name_is_absolute($absdir)) {
        $absdir = File::Spec->rel2abs($dir);
    }
    my $series = $self->get_series_file($dir);
    # Use default name if no series files exist yet
    $series = "$absdir/debian/patches/series" unless defined $series;
    unless (File::Spec->file_name_is_absolute($series)) {
        $series = File::Spec->rel2abs($series);
    }
    my %opts = (
        env => { QUILT_PATCHES => "$absdir/debian/patches",
                 QUILT_SERIES => $series },
        'chdir' => $dir,
        'exec' => [ 'quilt', '--quiltrc', '/dev/null', @$params ],
        %more_opts
    );
    my $pid = fork_and_exec(%opts);
    return $pid;
}

sub apply_patches {
    my ($self, $dir, $skip_auto) = @_;

    # Update debian/patches/series symlink if needed to allow quilt usage
    my $series = $self->get_series_file($dir);
    return unless $series; # No series, no patches
    my $basename = basename($series);
    if ($basename ne "series") {
        my $dest = File::Spec->catfile($dir, "debian", "patches", "series");
        unlink($dest) if -l $dest;
        unless (-f _) { # Don't overwrite real files
            symlink($basename, $dest) ||
                syserr(_g("can't create symlink %s"), $dest);
        }
    }
    my @patches = $self->get_patches($dir, $skip_auto);
    return unless scalar(@patches);

    # Apply patches
    my $applied = File::Spec->catfile($dir, "debian", "patches", ".dpkg-source-applied");
    open(APPLIED, '>', $applied) || syserr(_g("cannot write %s"), $applied);
    my $now = time();
    my $pobj = {};
    my $panalysis = {};
    foreach my $patch (@patches) {
        my $path = File::Spec->catfile($dir, "debian", "patches", $patch);
        $pobj->{$patch} = Dpkg::Source::Patch->new(filename => $path);
        if ($self->{'options'}{'without_quilt'}) {
            info(_g("applying %s"), $patch) unless $skip_auto;
            $pobj->{$patch}->apply($dir, timestamp => $now,
                    force_timestamp => 1, create_dirs => 1,
                    add_options => [ '-E' ]);
            print APPLIED "$patch\n";
        } else {
            $panalysis->{$patch} = $pobj->{$patch}->analyze($dir);
            foreach my $dir (keys %{$panalysis->{$patch}->{'dirtocreate'}}) {
                eval { mkpath($dir); };
                syserr(_g("cannot create directory %s"), $dir) if $@;
            }
        }
    }
    if (not $self->{'options'}{'without_quilt'}) {
        my %opts;
        $opts{"to_file"} = "/dev/null" if $skip_auto;
        info(_g("applying all patches with %s"), "quilt push -q " . $patches[-1]) unless $skip_auto;
        $self->run_quilt($dir, ['push', '-q', $patches[-1]],
                         delete_env => ['QUILT_PATCH_OPTS'],
                         wait_child => 1, %opts);
        foreach my $patch (@patches) {
            foreach my $fn (keys %{$panalysis->{$patch}->{'filepatched'}}) {
                utime($now, $now, $fn) || $! == ENOENT ||
                    syserr(_g("cannot change timestamp for %s"), $fn);
            }
            print APPLIED "$patch\n";
        }
    }
    close(APPLIED);
}

sub prepare_build {
    my ($self, $dir) = @_;
    $self->SUPER::prepare_build($dir);
    # Skip .pc directories of quilt by default and ignore difference
    # on debian/patches/series symlinks and d/p/.dpkg-source-applied
    # stamp file created by ourselves
    my $func = sub {
        return 1 if $_[0] =~ m{^debian/patches/series$} and -l $_[0];
        return 1 if $_[0] =~ m{^debian/patches/.dpkg-source-applied$};
        return 1 if $_[0] =~ /^.pc(\/|$)/;
        return 1 if $_[0] =~ /$self->{'options'}{'diff_ignore_regexp'}/;
        return 0;
    };
    $self->{'diff_options'}{'diff_ignore_func'} = $func;
}

sub check_patches_applied {
    my ($self, $dir) = @_;
    my $applied = File::Spec->catfile($dir, "debian", "patches", ".dpkg-source-applied");
    my $auto_patch = $self->get_autopatch_name();
    my @patches ;
    # First we try to get a list of patches that are probably not napplied
    if (not $self->{'options'}{'without_quilt'}) {
        my $pipe;
        my $pid = $self->run_quilt($dir, ['unapplied'], error_to_file => '/dev/null',
                                   to_pipe => \$pipe);
        @patches = map { chomp; $_ } (<$pipe>);
        close ($pipe) || syserr("close on 'quilt unapplied' pipe");
        wait_child($pid, cmdline => "quilt unapplied", nocheck => 1);
        subprocerr("quilt unapplied") unless WIFEXITED($?);
    } else {
        @patches = $self->get_patches($dir);
    }
    # Then we check if it's applicable, and if yes, we make the
    # assumption that patches are not applied and need to be applied
    if (scalar(@patches)) {
        my $first_patch = File::Spec->catfile($dir, "debian", "patches", $patches[0]);
        my $patch_obj = Dpkg::Source::Patch->new(filename => $first_patch);
        if ($patch_obj->check_apply($dir)) {
            warning(_g("patches have not been applied, applying them now (use --no-preparation to override)"));
            $self->apply_patches($dir);
        }
    }
}

sub register_autopatch {
    my ($self, $dir) = @_;
    my $auto_patch = $self->get_autopatch_name();
    my @patches = $self->get_patches($dir);
    my $has_patch = (grep { $_ eq $auto_patch } @patches) ? 1 : 0;
    my $series = $self->get_series_file($dir);
    $series ||= File::Spec->catfile($dir, "debian", "patches", "series");
    my $applied = File::Spec->catfile($dir, "debian", "patches", ".dpkg-source-applied");
    my $patch = File::Spec->catfile($dir, "debian", "patches", $auto_patch);
    my $absdir = $dir;
    unless (File::Spec->file_name_is_absolute($absdir)) {
        $absdir = File::Spec->rel2abs($dir);
    }
    if (-e $patch) {
        # Add auto_patch to series file
        if (not $has_patch) {
            # Use quilt to register only if it's wanted/available AND :
            # - either we have patches and quilt has been used (.pc dir exists)
            # - or we don't have patches, hence quilt couldn't be used
            if ((-d "$dir/.pc" or not scalar(@patches)) and
                not $self->{'options'}{'without_quilt'})
            {
                # Registering the new patch with quilt requires some
                # trickery: reverse-apply the patch, create a new quilt patch,
                # fold the patch into the quilt-managed one
                my $patch_obj = Dpkg::Source::Patch->new(filename => $patch);
                $patch_obj->apply($dir, add_options => ['-R', '-E']);
                $self->run_quilt($dir, ['new', "$auto_patch"],
                                 wait_child => 1, to_file => '/dev/null');
                $self->run_quilt($dir, ['fold'],
                                 from_file => "$absdir/debian/patches/$auto_patch",
                                 wait_child => 1, to_file => '/dev/null');
            } else {
                open(SERIES, ">>", $series) || syserr(_g("cannot write %s"), $series);
                print SERIES "$auto_patch\n";
                close(SERIES);
            }
        } else {
            # If quilt was used, ensure its meta-information are
            # synchronized with the updated patch
            if (-d "$dir/.pc" and not $self->{'options'}{'without_quilt'}) {
                # Some trickery needed: reverse-apply the patch, fold the
                # new patch into the quilt-managed one
                my $patch_obj = Dpkg::Source::Patch->new(filename => $patch);
                $patch_obj->apply($dir, add_options => ['-R', '-E']);
                $self->run_quilt($dir, ['fold'],
                                 from_file => "$absdir/debian/patches/$auto_patch",
                                 wait_child => 1, to_file => '/dev/null');
            }
        }
    } else {
        # Remove auto_patch from series
        if ($has_patch) {
            if ($self->{'options'}{'without_quilt'}) {
                open(SERIES, "<", $series) || syserr(_g("cannot read %s"), $series);
                my @lines = <SERIES>;
                close(SERIES);
                open(SERIES, ">", $series) || syserr(_g("cannot write %s"), $series);
                print(SERIES $_) foreach grep { not /^\Q$auto_patch\E\s*$/ } @lines;
                close(SERIES);
            } else {
                $self->run_quilt($dir, ['delete', $auto_patch],
                                 wait_child => 1, to_file => '/dev/null');
            }
        }
        # Clean up empty series
        unlink($series) if not -s $series;
    }
}

sub get_patch_header {
    my ($self, $dir, $previous) = @_;
    my $ch_info = changelog_parse(offset => 0, count => 1,
        file => File::Spec->catfile($dir, "debian", "changelog"));
    return '' if not defined $ch_info;
    my $header = Dpkg::Control->new(type => CTRL_UNKNOWN);
    $header->{'Description'} = "Upstream changes introduced in version " .
                               $ch_info->{'Version'} . "\n";
    $header->{'Description'} .=
"This patch has been created by dpkg-source during the package build.
Here's the last changelog entry, hopefully it gives details on why
those changes were made:\n";
    $header->{'Description'} .= $ch_info->{'Changes'} . "\n";
    $header->{'Description'} .=
"\nThe person named in the Author field signed this changelog entry.\n";
    $header->{'Author'} = $ch_info->{'Maintainer'};
    my $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: <vendor|upstream|other>, <url of original patch>
Bug: <url in upstream bugtracker>
Bug-Debian: http://bugs.debian.org/<bugnumber>
Forwarded: <no|not-needed|url proving that it has been forwarded>
Reviewed-By: <name and email of someone who approved the patch>
Last-Update: <YYYY-MM-DD>\n\n";
    return $text;
}

# vim:et:sw=4:ts=8
1;