File Coverage

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

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