File Coverage

File:Dpkg/Source/Quilt.pm
Coverage:30.9%

linestmtbrancondsubpodtimecode
1# Copyright © 2008-2012 Raphaël Hertzog <hertzog@debian.org>
2#
3# This program is free software; you can redistribute it and/or modify
4# it under the terms of the GNU General Public License as published by
5# the Free Software Foundation; either version 2 of the License, or
6# (at your option) any later version.
7#
8# This program is distributed in the hope that it will be useful,
9# but WITHOUT ANY WARRANTY; without even the implied warranty of
10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11# GNU General Public License for more details.
12#
13# You should have received a copy of the GNU General Public License
14# along with this program.  If not, see <https://www.gnu.org/licenses/>.
15
16=encoding utf8
17
18 - 28
=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
29
30package Dpkg::Source::Quilt 0.02;
31
32
3
3
3
3
7
2
39
use strict;
33
3
3
3
3
6
0
69
use warnings;
34
35
3
3
3
3
6
2
130
use List::Util qw(any none);
36
3
3
3
3
3
3
25
use File::Spec;
37
3
3
3
3
435
6172
95
use File::Copy;
38
3
3
3
3
8
1
65
use File::Find;
39
3
3
3
3
5
2
51
use File::Path qw(make_path);
40
3
3
3
3
7
0
60
use File::Basename;
41
42
3
3
3
3
411
4
87
use Dpkg::Gettext;
43
3
3
3
3
437
3
107
use Dpkg::ErrorHandling;
44
3
3
3
3
338
2
63
use Dpkg::File;
45
3
3
3
3
439
3
90
use Dpkg::Source::Patch;
46
3
3
3
3
7
3
65
use Dpkg::Source::Functions qw(erasedir chmod_if_needed fs_time);
47
3
3
3
3
390
3
3173
use Dpkg::Vendor qw(get_current_vendor);
48
49sub new {
50
3
3
0
5
    my ($this, $dir, %opts) = @_;
51
3
33
13
    my $class = ref($this) || $this;
52
53
3
5
    my $self = {
54        dir => $dir,
55    };
56
3
4
    bless $self, $class;
57
58
3
6
    $self->load_series();
59
3
6
    $self->load_db();
60
61
3
5
    return $self;
62}
63
64sub setup_db {
65
0
0
0
0
    my $self = shift;
66
0
0
    my $db_dir = $self->get_db_dir();
67
0
0
0
    if (not -d $db_dir) {
68
0
0
0
        mkdir $db_dir or syserr(g_('cannot mkdir %s'), $db_dir);
69    }
70
0
0
    my $file = $self->get_db_file('.version');
71
0
0
0
    if (not -e $file) {
72
0
0
        file_dump($file, "2\n");
73    }
74    # The files below are used by quilt to know where patches are stored
75    # and what file contains the patch list (supported by quilt >= 0.48-5
76    # in Debian).
77
0
0
    $file = $self->get_db_file('.quilt_patches');
78
0
0
0
    if (not -e $file) {
79
0
0
        file_dump($file, "debian/patches\n");
80    }
81
0
0
    $file = $self->get_db_file('.quilt_series');
82
0
0
0
    if (not -e $file) {
83
0
0
        my $series = $self->get_series_file();
84
0
0
        $series = (File::Spec->splitpath($series))[2];
85
0
0
        file_dump($file, "$series\n");
86    }
87}
88
89sub load_db {
90
3
3
0
3
    my $self = shift;
91
92
3
3
    my $pc_applied = $self->get_db_file('applied-patches');
93
3
3
    $self->{applied_patches} = [ $self->read_patch_list($pc_applied) ];
94}
95
96sub save_db {
97
0
0
0
0
    my $self = shift;
98
99
0
0
    $self->setup_db();
100
0
0
    my $pc_applied = $self->get_db_file('applied-patches');
101
0
0
    $self->write_patch_list($pc_applied, $self->{applied_patches});
102}
103
104sub load_series {
105
3
3
0
3
    my ($self, %opts) = @_;
106
107
3
7
    my $series = $self->get_series_file();
108
3
6
    $self->{series} = [ $self->read_patch_list($series, %opts) ];
109}
110
111sub series {
112
3
3
0
74
    my $self = shift;
113
3
3
115
7
    return @{$self->{series}};
114}
115
116sub applied {
117
0
0
0
0
    my $self = shift;
118
0
0
0
0
    return @{$self->{applied_patches}};
119}
120
121sub top {
122
0
0
0
0
    my $self = shift;
123
0
0
0
0
    my $count = scalar @{$self->{applied_patches}};
124
0
0
0
    return $self->{applied_patches}[$count - 1] if $count;
125
0
0
    return;
126}
127
128sub register {
129
0
0
0
0
    my ($self, $patch_name) = @_;
130
131
0
0
0
0
0
0
0
0
    return if any { $_ eq $patch_name } @{$self->{series}};
132
133    # Add patch to series files.
134
0
0
    $self->setup_db();
135
0
0
    $self->_file_add_line($self->get_series_file(), $patch_name);
136
0
0
    $self->_file_add_line($self->get_db_file('applied-patches'), $patch_name);
137
0
0
    $self->load_db();
138
0
0
    $self->load_series();
139
140    # Ensure quilt meta-data is created and in sync with some trickery:
141    # Reverse-apply the patch, drop .pc/$patch, and re-apply it with the
142    # correct options to recreate the backup files.
143
0
0
    $self->pop(reverse_apply => 1);
144
0
0
    $self->push();
145}
146
147sub unregister {
148
0
0
0
0
    my ($self, $patch_name) = @_;
149
150
0
0
0
0
0
0
0
0
    return if none { $_ eq $patch_name } @{$self->{series}};
151
152
0
0
    my $series = $self->get_series_file();
153
154
0
0
    $self->_file_drop_line($series, $patch_name);
155
0
0
    $self->_file_drop_line($self->get_db_file('applied-patches'), $patch_name);
156
0
0
    erasedir($self->get_db_file($patch_name));
157
0
0
    $self->load_db();
158
0
0
    $self->load_series();
159
160    # Clean up empty series.
161
0
0
0
    unlink $series if -z $series;
162}
163
164sub next {
165
0
0
0
0
    my $self = shift;
166
0
0
0
0
    my $count_applied = scalar @{$self->{applied_patches}};
167
0
0
0
0
    my $count_series = scalar @{$self->{series}};
168
0
0
0
    return $self->{series}[$count_applied] if ($count_series > $count_applied);
169
0
0
    return;
170}
171
172sub push {
173
0
0
0
0
    my ($self, %opts) = @_;
174
0
0
0
    $opts{verbose} //= 0;
175
0
0
0
    $opts{timestamp} //= fs_time($self->{dir});
176
177
0
0
    my $patch = $self->next();
178
0
0
0
    return unless defined $patch;
179
180
0
0
    my $path = $self->get_patch_file($patch);
181
0
0
    my $obj = Dpkg::Source::Patch->new(filename => $path);
182
183
0
0
0
    info(g_('applying %s'), $patch) if $opts{verbose};
184
0
0
    eval {
185        $obj->apply($self->{dir}, timestamp => $opts{timestamp},
186                    verbose => $opts{verbose},
187
0
0
                    force_timestamp => 1, create_dirs => 1, remove_backup => 0,
188                    options => [ '-t', '-F', '0', '-N', '-p1', '-u',
189                                 '-V', 'never', '-E', '-b',
190                                 '-B', ".pc/$patch/", '--reject-file=-' ]);
191    };
192
0
0
0
    if ($@) {
193
0
0
        info(g_('the patch has fuzz which is not allowed, or is malformed'));
194
0
0
        info(g_("if patch '%s' is correctly applied by quilt, use '%s' to update it"),
195             $patch, 'quilt refresh');
196
0
0
        info(g_('if the file is present in the unpacked source, make sure it ' .
197                'is also present in the orig tarball'));
198
0
0
        $self->restore_quilt_backup_files($patch, %opts);
199
0
0
        erasedir($self->get_db_file($patch));
200
0
0
        die $@;
201    }
202
0
0
0
0
    CORE::push @{$self->{applied_patches}}, $patch;
203
0
0
    $self->save_db();
204}
205
206sub pop {
207
0
0
0
0
    my ($self, %opts) = @_;
208
0
0
0
    $opts{verbose} //= 0;
209
0
0
0
    $opts{timestamp} //= fs_time($self->{dir});
210
0
0
0
    $opts{reverse_apply} //= 0;
211
212
0
0
    my $patch = $self->top();
213
0
0
0
    return unless defined $patch;
214
215
0
0
0
    info(g_('unapplying %s'), $patch) if $opts{verbose};
216
0
0
    my $backup_dir = $self->get_db_file($patch);
217
0
0
0
0
    if (-d $backup_dir and not $opts{reverse_apply}) {
218        # Use the backup copies to restore
219
0
0
        $self->restore_quilt_backup_files($patch);
220    } else {
221        # Otherwise reverse-apply the patch
222
0
0
        my $path = $self->get_patch_file($patch);
223
0
0
        my $obj = Dpkg::Source::Patch->new(filename => $path);
224
225        $obj->apply($self->{dir}, timestamp => $opts{timestamp},
226
0
0
                    verbose => 0, force_timestamp => 1, remove_backup => 0,
227                    options => [ '-R', '-t', '-N', '-p1',
228                                 '-u', '-V', 'never', '-E',
229                                 '--no-backup-if-mismatch' ]);
230    }
231
232
0
0
    erasedir($backup_dir);
233
0
0
0
0
    pop @{$self->{applied_patches}};
234
0
0
    $self->save_db();
235}
236
237sub get_db_version {
238
0
0
0
0
    my $self = shift;
239
0
0
    my $pc_ver = $self->get_db_file('.version');
240
0
0
0
    if (-f $pc_ver) {
241
0
0
        my $version = file_slurp($pc_ver);
242
0
0
        chomp $version;
243
0
0
        return $version;
244    }
245
0
0
    return;
246}
247
248sub find_problems {
249
0
0
0
0
    my $self = shift;
250
0
0
    my $patch_dir = $self->get_patch_dir();
251
0
0
0
0
    if (-e $patch_dir and not -d _) {
252
0
0
        return sprintf(g_('%s should be a directory or non-existing'), $patch_dir);
253    }
254
0
0
    my $series = $self->get_series_file();
255
0
0
0
0
    if (-e $series and not -f _) {
256
0
0
        return sprintf(g_('%s should be a file or non-existing'), $series);
257    }
258
0
0
    return;
259}
260
261sub get_series_file {
262
3
3
0
2
    my $self = shift;
263
3
50
7
    my $vendor = lc(get_current_vendor() || 'debian');
264    # Series files are stored alongside patches
265
3
19
    my $default_series = $self->get_patch_file('series');
266
3
4
    my $vendor_series = $self->get_patch_file("$vendor.series");
267
3
50
21
    return $vendor_series if -e $vendor_series;
268
3
3
    return $default_series;
269}
270
271sub get_db_file {
272
3
3
0
4
    my ($self, $file) = @_;
273
274
3
5
    return File::Spec->catfile($self->get_db_dir(), $file);
275}
276
277sub get_db_dir {
278
3
3
0
1
    my $self = shift;
279
280
3
20
    return File::Spec->catfile($self->{dir}, '.pc');
281}
282
283sub get_patch_file {
284
6
6
0
5
    my ($self, $file) = @_;
285
286
6
21
    return File::Spec->catfile($self->get_patch_dir(), $file);
287}
288
289sub get_patch_dir {
290
6
6
0
3
    my $self = shift;
291
292
6
54
    return File::Spec->catfile($self->{dir}, 'debian', 'patches');
293}
294
295## METHODS BELOW ARE INTERNAL ##
296
297sub _file_load {
298
0
0
0
    my ($self, $file) = @_;
299
300
0
0
0
    open my $file_fh, '<', $file or syserr(g_('cannot read %s'), $file);
301
0
0
    my @lines = <$file_fh>;
302
0
0
    close $file_fh;
303
304
0
0
    return @lines;
305}
306
307sub _file_add_line {
308
0
0
0
    my ($self, $file, $line) = @_;
309
310
0
0
    my @lines;
311
0
0
0
    @lines = $self->_file_load($file) if -f $file;
312
0
0
    CORE::push @lines, $line;
313
0
0
    chomp @lines;
314
315
0
0
0
    open my $file_fh, '>', $file or syserr(g_('cannot write %s'), $file);
316
0
0
0
0
    print { $file_fh } "$_\n" foreach @lines;
317
0
0
    close $file_fh;
318}
319
320sub _file_drop_line {
321
0
0
0
    my ($self, $file, $re) = @_;
322
323
0
0
    my @lines = $self->_file_load($file);
324
0
0
0
    open my $file_fh, '>', $file or syserr(g_('cannot write %s'), $file);
325
0
0
0
0
0
0
    print { $file_fh } $_ foreach grep { not /^\Q$re\E\s*$/ } @lines;
326
0
0
    close $file_fh;
327}
328
329sub read_patch_list {
330
6
6
0
6
    my ($self, $file, %opts) = @_;
331
6
100
67
33
    return () if not defined $file or not -f $file;
332
3
50
10
    $opts{warn_options} //= 0;
333
3
3
    my @patches;
334
3
50
24
    open(my $series_fh, '<' , $file) or syserr(g_('cannot read %s'), $file);
335
3
13
    while (defined(my $line = <$series_fh>)) {
336
27
14
        chomp $line;
337        # Strip leading/trailing spaces
338
27
26
        $line =~ s/^\s+//;
339
27
23
        $line =~ s/\s+$//;
340        # Strip comment
341
27
21
        $line =~ s/(?:^|\s+)#.*$//;
342
27
100
35
        next unless $line;
343
12
100
18
        if ($line =~ /^(\S+)\s+(.*)$/) {
344
6
6
            $line = $1;
345
6
50
8
            if ($2 ne '-p1') {
346                warning(g_('the series file (%s) contains unsupported ' .
347                           "options ('%s', line %s); dpkg-source might " .
348                           'fail when applying patches'),
349
0
0
0
                        $file, $2, $.) if $opts{warn_options};
350            }
351        }
352
12
50
10
        if ($line =~ m{(^|/)\.\./}) {
353
0
0
            error(g_('%s contains an insecure path: %s'), $file, $line);
354        }
355
12
14
        CORE::push @patches, $line;
356    }
357
3
6
    close($series_fh);
358
3
11
    return @patches;
359}
360
361sub write_patch_list {
362
0
0
0
    my ($self, $series, $patches) = @_;
363
364
0
0
    open my $series_fh, '>', $series or syserr(g_('cannot write %s'), $series);
365
0
0
    foreach my $patch (@{$patches}) {
366
0
0
        print { $series_fh } "$patch\n";
367    }
368
0
    close $series_fh;
369}
370
371sub restore_quilt_backup_files {
372
0
0
0
    my ($self, $patch, %opts) = @_;
373
0
    my $patch_dir = $self->get_db_file($patch);
374
0
0
    return unless -d $patch_dir;
375
0
0
    info(g_('restoring quilt backup files for %s'), $patch) if $opts{verbose};
376    find({
377        no_chdir => 1,
378        wanted => sub {
379
0
0
0
            return if -d;
380
0
            my $relpath_in_srcpkg = File::Spec->abs2rel($_, $patch_dir);
381
0
            my $target = File::Spec->catfile($self->{dir}, $relpath_in_srcpkg);
382
0
0
            if (-s) {
383
0
                unlink($target);
384
0
                make_path(dirname($target));
385
0
0
                unless (link($_, $target)) {
386
0
0
                    copy($_, $target)
387                        or syserr(g_('failed to copy %s to %s'), $_, $target);
388
0
0
                    chmod_if_needed((stat _)[2], $target)
389                        or syserr(g_("unable to change permission of '%s'"), $target);
390                }
391            } else {
392                # empty files are "backups" for new files that patch created
393
0
                unlink($target);
394            }
395        }
396
0
    }, $patch_dir);
397}
398
399 - 405
=head1 CHANGES

=head2 Version 0.xx

This is a private module.

=cut
406
4071;