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