scripts/Dpkg/Source/Quilt.pm

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