view release on metacpan or  search on metacpan

lib/Dpkg/Source/Quilt.pm  view on Meta::CPAN

# Copyright © 2008-2012 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 <https://www.gnu.org/licenses/>.

=encoding utf8

=head1 NAME

Dpkg::Source::Quilt - represent a quilt patch queue

=head1 DESCRIPTION

This module provides a class to handle quilt patch queues.

B<Note>: This is a private module, its API can change at any time.

=cut

package Dpkg::Source::Quilt 0.02;

use v5.36;

use List::Util qw(any none);
use File::Spec;
use File::Copy;
use File::Find;
use File::Path qw(make_path);
use File::Basename;

use Dpkg::Gettext;
use Dpkg::ErrorHandling;
use Dpkg::File;
use Dpkg::Source::Patch;
use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time);
use Dpkg::Vendor qw(get_current_vendor);

sub new {
    my ($this, $dir, %opts) = @_;
    my $class = ref($this) || $this;

    my $self = {
        dir => $dir,
    };
    bless $self, $class;

    $self->load_series();
    $self->load_db();

    return $self;
}

sub setup_db {
    my $self = shift;
    my $db_dir = $self->get_db_dir();
    if (not -d $db_dir) {
        mkdir $db_dir or syserr(g_('cannot mkdir %s'), $db_dir);
    }
    my $file = $self->get_db_file('.version');
    if (not -e $file) {
        file_dump($file, "2\n");
    }
    # The files below are used by quilt to know where patches are stored
    # and what file contains the patch list (supported by quilt >= 0.48-5
    # in Debian).
    $file = $self->get_db_file('.quilt_patches');
    if (not -e $file) {
        file_dump($file, "debian/patches\n");
    }
    $file = $self->get_db_file('.quilt_series');
    if (not -e $file) {
        my $series = $self->get_series_file();
        $series = (File::Spec->splitpath($series))[2];
        file_dump($file, "$series\n");
    }
}

sub load_db {
    my $self = shift;

    my $pc_applied = $self->get_db_file('applied-patches');
    $self->{applied_patches} = [ $self->read_patch_list($pc_applied) ];
}

sub save_db {
    my $self = shift;

    $self->setup_db();
    my $pc_applied = $self->get_db_file('applied-patches');
    $self->write_patch_list($pc_applied, $self->{applied_patches});
}

sub load_series {
    my ($self, %opts) = @_;

lib/Dpkg/Source/Quilt.pm  view on Meta::CPAN

sub read_patch_list {
    my ($self, $file, %opts) = @_;
    return () if not defined $file or not -f $file;
    $opts{warn_options} //= 0;
    my @patches;
    open(my $series_fh, '<' , $file) or syserr(g_('cannot read %s'), $file);
    while (defined(my $line = <$series_fh>)) {
        chomp $line;
        # Strip leading/trailing spaces.
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        # Strip comment.
        $line =~ s/(?:^|\s+)#.*$//;
        next unless $line;
        if ($line =~ /^(\S+)\s+(.*)$/) {
            $line = $1;
            if ($2 ne '-p1') {
                warning(g_('the series file (%s) contains unsupported ' .
                           "options ('%s', line %s); dpkg-source might " .
                           'fail when applying patches'),
                        $file, $2, $.) if $opts{warn_options};
            }
        }
        if ($line =~ m{(^|/)\.\./}) {
            error(g_('%s contains an insecure path: %s'), $file, $line);
        }
        CORE::push @patches, $line;
    }
    close($series_fh);
    return @patches;
}

sub write_patch_list {
    my ($self, $series, $patches) = @_;

    open my $series_fh, '>', $series or syserr(g_('cannot write %s'), $series);
    foreach my $patch (@{$patches}) {
        print { $series_fh } "$patch\n";
    }
    close $series_fh;
}

sub restore_quilt_backup_files {
    my ($self, $patch, %opts) = @_;
    my $patch_dir = $self->get_db_file($patch);
    return unless -d $patch_dir;
    info(g_('restoring quilt backup files for %s'), $patch) if $opts{verbose};
    my $scan_quilt = {
        no_chdir => 1,
        wanted => sub {
            return if -d;
            my $relpath_in_srcpkg = File::Spec->abs2rel($_, $patch_dir);
            my $target = File::Spec->catfile($self->{dir}, $relpath_in_srcpkg);
            if (-s) {
                unlink($target);
                make_path(dirname($target));
                unless (link($_, $target)) {
                    copy($_, $target)
                        or syserr(g_('failed to copy %s to %s'), $_, $target);
                    chmod_if_needed((stat _)[2], $target)
                        or syserr(g_("unable to change permission of '%s'"), $target);
                }
            } else {
                # Empty files are "backups" for new files that patch created.
                unlink($target);
            }
        },
    };
    find($scan_quilt, $patch_dir);
}

=head1 CHANGES

=head2 Version 0.xx

This is a private module.

=cut

1;