chiark - git - mdw - dpkg/blob - scripts/Dpkg/Source/Package/V1.pm

   1 # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org>
   2 # Copyright © 2008, 2012-2015 Guillem Jover <guillem@debian.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 package Dpkg::Source::Package::V1;
  18
  19 use strict;
  20 use warnings;
  21
  22 our $VERSION = '0.01';
  23
  24 use POSIX qw(:errno_h);
  25 use Cwd;
  26 use File::Basename;
  27 use File::Temp qw(tempfile);
  28 use File::Spec;
  29
  30 use Dpkg ();
  31 use Dpkg::Gettext;
  32 use Dpkg::ErrorHandling;
  33 use Dpkg::Compression;
  34 use Dpkg::Source::Archive;
  35 use Dpkg::Source::Patch;
  36 use Dpkg::Exit qw(push_exit_handler pop_exit_handler);
  37 use Dpkg::Source::Functions qw(erasedir);
  38 use Dpkg::Source::Package::V3::Native;
  39
  40 use parent qw(Dpkg::Source::Package);
  41
  42 our $CURRENT_MINOR_VERSION = '0';
  43
  44 sub init_options {
  45     my $self = shift;
  46
  47     # Don't call $self->SUPER::init_options() on purpose, V1.0 has no
  48     # ignore by default
  49     if ($self->{options}{diff_ignore_regex}) {
  50         $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$';
  51     } else {
  52         $self->{options}{diff_ignore_regex} = '(?:^|/)debian/source/local-.*$';
  53     }
  54     $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$';
  55     push @{$self->{options}{tar_ignore}},
  56          'debian/source/local-options',
  57          'debian/source/local-patch-header',
  58          'debian/files',
  59          'debian/files.new';
  60     $self->{options}{sourcestyle} //= 'X';
  61     $self->{options}{skip_debianization} //= 0;
  62     $self->{options}{ignore_bad_version} //= 0;
  63     $self->{options}{abort_on_upstream_changes} //= 0;
  64
  65     # V1.0 only supports gzip compression.
  66     $self->{options}{compression} //= 'gzip';
  67     $self->{options}{comp_level} //= compression_get_property('gzip', 'default_level');
  68     $self->{options}{comp_ext} //= compression_get_property('gzip', 'file_ext');
  69 }
  70
  71 my @module_cmdline = (
  72     {
  73         name => '-sa',
  74         help => N_('auto select original source'),
  75         when => 'build',
  76     }, {
  77         name => '-sk',
  78         help => N_('use packed original source (unpack and keep)'),
  79         when => 'build',
  80     }, {
  81         name => '-sp',
  82         help => N_('use packed original source (unpack and remove)'),
  83         when => 'build',
  84     }, {
  85         name => '-su',
  86         help => N_('use unpacked original source (pack and keep)'),
  87         when => 'build',
  88     }, {
  89         name => '-sr',
  90         help => N_('use unpacked original source (pack and remove)'),
  91         when => 'build',
  92     }, {
  93         name => '-ss',
  94         help => N_('trust packed and unpacked original sources are same'),
  95         when => 'build',
  96     }, {
  97         name => '-sn',
  98         help => N_('there is no diff, do main tarfile only'),
  99         when => 'build',
 100     }, {
 101         name => '-sA, -sK, -sP, -sU, -sR',
 102         help => N_('like -sa, -sk, -sp, -su, -sr but may overwrite'),
 103         when => 'build',
 104     }, {
 105         name => '--abort-on-upstream-changes',
 106         help => N_('abort if generated diff has upstream files changes'),
 107         when => 'build',
 108     }, {
 109         name => '-sp',
 110         help => N_('leave original source packed in current directory'),
 111         when => 'extract',
 112     }, {
 113         name => '-su',
 114         help => N_('do not copy original source to current directory'),
 115         when => 'extract',
 116     }, {
 117         name => '-sn',
 118         help => N_('unpack original source tree too'),
 119         when => 'extract',
 120     }, {
 121         name => '--skip-debianization',
 122         help => N_('do not apply debian diff to upstream sources'),
 123         when => 'extract',
 124     },
 125 );
 126
 127 sub describe_cmdline_options {
 128     return @module_cmdline;
 129 }
 130
 131 sub parse_cmdline_option {
 132     my ($self, $opt) = @_;
 133     my $o = $self->{options};
 134     if ($opt =~ m/^-s([akpursnAKPUR])$/) {
 135         warning(g_('-s%s option overrides earlier -s%s option'), $1,
 136                 $o->{sourcestyle}) if $o->{sourcestyle} ne 'X';
 137         $o->{sourcestyle} = $1;
 138         $o->{copy_orig_tarballs} = 0 if $1 eq 'n'; # Extract option -sn
 139         return 1;
 140     } elsif ($opt eq '--skip-debianization') {
 141         $o->{skip_debianization} = 1;
 142         return 1;
 143     } elsif ($opt eq '--ignore-bad-version') {
 144         $o->{ignore_bad_version} = 1;
 145         return 1;
 146     } elsif ($opt eq '--abort-on-upstream-changes') {
 147         $o->{abort_on_upstream_changes} = 1;
 148         return 1;
 149     }
 150     return 0;
 151 }
 152
 153 sub do_extract {
 154     my ($self, $newdirectory) = @_;
 155     my $sourcestyle = $self->{options}{sourcestyle};
 156     my $fields = $self->{fields};
 157
 158     $sourcestyle =~ y/X/p/;
 159     unless ($sourcestyle =~ m/[pun]/) {
 160         usageerr(g_('source handling style -s%s not allowed with -x'),
 161                  $sourcestyle);
 162     }
 163
 164     my $dscdir = $self->{basedir};
 165
 166     my $basename = $self->get_basename();
 167     my $basenamerev = $self->get_basename(1);
 168
 169     # V1.0 only supports gzip compression
 170     my ($tarfile, $difffile);
 171     my $tarsign;
 172     foreach my $file ($self->get_files()) {
 173         if ($file =~ /^(?:\Q$basename\E\.orig|\Q$basenamerev\E)\.tar\.gz$/) {
 174             error(g_('multiple tarfiles in v1.0 source package')) if $tarfile;
 175             $tarfile = $file;
 176         } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.gz\.asc$/) {
 177             $tarsign = $file;
 178         } elsif ($file =~ /^\Q$basenamerev\E\.diff\.gz$/) {
 179             $difffile = $file;
 180         } else {
 181             error(g_('unrecognized file for a %s source package: %s'),
 182                   'v1.0', $file);
 183         }
 184     }
 185
 186     error(g_('no tarfile in Files field')) unless $tarfile;
 187     my $native = $difffile ? 0 : 1;
 188     if ($native and ($tarfile =~ /\.orig\.tar\.gz$/)) {
 189         warning(g_('native package with .orig.tar'));
 190         $native = 0; # V3::Native doesn't handle orig.tar
 191     }
 192
 193     if ($native) {
 194         Dpkg::Source::Package::V3::Native::do_extract($self, $newdirectory);
 195     } else {
 196         my $expectprefix = $newdirectory;
 197         $expectprefix .= '.orig';
 198
 199         if ($self->{options}{no_overwrite_dir} and -e $newdirectory) {
 200             error(g_('unpack target exists: %s'), $newdirectory);
 201         } else {
 202             erasedir($newdirectory);
 203         }
 204         if (-e $expectprefix) {
 205             rename($expectprefix, "$newdirectory.tmp-keep")
 206                 or syserr(g_("unable to rename '%s' to '%s'"), $expectprefix,
 207                           "$newdirectory.tmp-keep");
 208         }
 209
 210         info(g_('unpacking %s'), $tarfile);
 211         my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
 212         $tar->extract($expectprefix);
 213
 214         if ($sourcestyle =~ /u/) {
 215             # -su: keep .orig directory unpacked
 216             if (-e "$newdirectory.tmp-keep") {
 217                 error(g_('unable to keep orig directory (already exists)'));
 218             }
 219             system('cp', '-ar', '--', $expectprefix, "$newdirectory.tmp-keep");
 220             subprocerr("cp $expectprefix to $newdirectory.tmp-keep") if $?;
 221         }
 222
 223         rename($expectprefix, $newdirectory)
 224             or syserr(g_('failed to rename newly-extracted %s to %s'),
 225                       $expectprefix, $newdirectory);
 226
 227         # rename the copied .orig directory
 228         if (-e "$newdirectory.tmp-keep") {
 229             rename("$newdirectory.tmp-keep", $expectprefix)
 230                 or syserr(g_('failed to rename saved %s to %s'),
 231                           "$newdirectory.tmp-keep", $expectprefix);
 232         }
 233     }
 234
 235     if ($difffile and not $self->{options}{skip_debianization}) {
 236         my $patch = "$dscdir$difffile";
 237         info(g_('applying %s'), $difffile);
 238         my $patch_obj = Dpkg::Source::Patch->new(filename => $patch);
 239         my $analysis = $patch_obj->apply($newdirectory, force_timestamp => 1);
 240         my @files = grep { ! m{^\Q$newdirectory\E/debian/} }
 241                     sort keys %{$analysis->{filepatched}};
 242         info(g_('upstream files that have been modified: %s'),
 243              "\n " . join("\n ", @files)) if scalar @files;
 244     }
 245 }
 246
 247 sub can_build {
 248     my ($self, $dir) = @_;
 249
 250     # As long as we can use gzip, we can do it as we have
 251     # native packages as fallback
 252     return (0, g_('only supports gzip compression'))
 253         unless $self->{options}{compression} eq 'gzip';
 254     return 1;
 255 }
 256
 257 sub do_build {
 258     my ($self, $dir) = @_;
 259     my $sourcestyle = $self->{options}{sourcestyle};
 260     my @argv = @{$self->{options}{ARGV}};
 261     my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}};
 262     my $diff_ignore_regex = $self->{options}{diff_ignore_regex};
 263
 264     if (scalar(@argv) > 1) {
 265         usageerr(g_('-b takes at most a directory and an orig source ' .
 266                     'argument (with v1.0 source package)'));
 267     }
 268
 269     $sourcestyle =~ y/X/A/;
 270     unless ($sourcestyle =~ m/[akpursnAKPUR]/) {
 271         usageerr(g_('source handling style -s%s not allowed with -b'),
 272                  $sourcestyle);
 273     }
 274
 275     my $sourcepackage = $self->{fields}{'Source'};
 276     my $basenamerev = $self->get_basename(1);
 277     my $basename = $self->get_basename();
 278     my $basedirname = $basename;
 279     $basedirname =~ s/_/-/;
 280
 281     # Try to find a .orig tarball for the package
 282     my $origdir = "$dir.orig";
 283     my $origtargz = $self->get_basename() . '.orig.tar.gz';
 284     if (-e $origtargz) {
 285         unless (-f $origtargz) {
 286             error(g_("packed orig '%s' exists but is not a plain file"), $origtargz);
 287         }
 288     } else {
 289         $origtargz = undef;
 290     }
 291
 292     if (@argv) {
 293         # We have a second-argument <orig-dir> or <orig-targz>, check what it
 294         # is to decide the mode to use
 295         my $origarg = shift(@argv);
 296         if (length($origarg)) {
 297             stat($origarg)
 298                 or syserr(g_('cannot stat orig argument %s'), $origarg);
 299             if (-d _) {
 300                 $origdir = File::Spec->catdir($origarg);
 301
 302                 $sourcestyle =~ y/aA/rR/;
 303                 unless ($sourcestyle =~ m/[ursURS]/) {
 304                     error(g_('orig argument is unpacked but source handling ' .
 305                              'style -s%s calls for packed (.orig.tar.<ext>)'),
 306                           $sourcestyle);
 307                 }
 308             } elsif (-f _) {
 309                 $origtargz = $origarg;
 310                 $sourcestyle =~ y/aA/pP/;
 311                 unless ($sourcestyle =~ m/[kpsKPS]/) {
 312                     error(g_('orig argument is packed but source handling ' .
 313                              'style -s%s calls for unpacked (.orig/)'),
 314                           $sourcestyle);
 315                 }
 316             } else {
 317                 error(g_('orig argument %s is not a plain file or directory'),
 318                       $origarg);
 319             }
 320         } else {
 321             $sourcestyle =~ y/aA/nn/;
 322             unless ($sourcestyle =~ m/n/) {
 323                 error(g_('orig argument is empty (means no orig, no diff) ' .
 324                          'but source handling style -s%s wants something'),
 325                       $sourcestyle);
 326             }
 327         }
 328     } elsif ($sourcestyle =~ m/[aA]/) {
 329         # We have no explicit <orig-dir> or <orig-targz>, try to use
 330         # a .orig tarball first, then a .orig directory and fall back to
 331         # creating a native .tar.gz
 332         if ($origtargz) {
 333             $sourcestyle =~ y/aA/pP/; # .orig.tar.<ext>
 334         } else {
 335             if (stat($origdir)) {
 336                 unless (-d _) {
 337                     error(g_("unpacked orig '%s' exists but is not a directory"),
 338                           $origdir);
 339                 }
 340                 $sourcestyle =~ y/aA/rR/; # .orig directory
 341             } elsif ($! != ENOENT) {
 342                 syserr(g_("unable to stat putative unpacked orig '%s'"), $origdir);
 343             } else {
 344                 $sourcestyle =~ y/aA/nn/; # Native tar.gz
 345             }
 346         }
 347     }
 348
 349     my ($dirname, $dirbase) = fileparse($dir);
 350     if ($dirname ne $basedirname) {
 351         warning(g_("source directory '%s' is not <sourcepackage>" .
 352                    "-<upstreamversion> '%s'"), $dir, $basedirname);
 353     }
 354
 355     my ($tarname, $tardirname, $tardirbase);
 356     my $tarsign;
 357     if ($sourcestyle ne 'n') {
 358         my ($origdirname, $origdirbase) = fileparse($origdir);
 359
 360         if ($origdirname ne "$basedirname.orig") {
 361             warning(g_('.orig directory name %s is not <package>' .
 362                        '-<upstreamversion> (wanted %s)'),
 363                     $origdirname, "$basedirname.orig");
 364         }
 365         $tardirbase = $origdirbase;
 366         $tardirname = $origdirname;
 367
 368         $tarname = $origtargz || "$basename.orig.tar.gz";
 369         $tarsign = "$tarname.asc";
 370         unless ($tarname =~ /\Q$basename\E\.orig\.tar\.gz/) {
 371             warning(g_('.orig.tar name %s is not <package>_<upstreamversion>' .
 372                        '.orig.tar (wanted %s)'),
 373                     $tarname, "$basename.orig.tar.gz");
 374         }
 375     }
 376
 377     if ($sourcestyle eq 'n') {
 378         $self->{options}{ARGV} = []; # ensure we have no error
 379         Dpkg::Source::Package::V3::Native::do_build($self, $dir);
 380     } elsif ($sourcestyle =~ m/[urUR]/) {
 381         if (stat($tarname)) {
 382             unless ($sourcestyle =~ m/[UR]/) {
 383                 error(g_("tarfile '%s' already exists, not overwriting, " .
 384                          'giving up; use -sU or -sR to override'), $tarname);
 385             }
 386         } elsif ($! != ENOENT) {
 387             syserr(g_("unable to check for existence of '%s'"), $tarname);
 388         }
 389
 390         info(g_('building %s in %s'),
 391              $sourcepackage, $tarname);
 392
 393         my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX",
 394                                        DIR => getcwd(), UNLINK => 0);
 395         my $tar = Dpkg::Source::Archive->new(filename => $newtar,
 396                     compression => compression_guess_from_filename($tarname),
 397                     compression_level => $self->{options}{comp_level});
 398         $tar->create(options => \@tar_ignore, chdir => $tardirbase);
 399         $tar->add_directory($tardirname);
 400         $tar->finish();
 401         rename($newtar, $tarname)
 402             or syserr(g_("unable to rename '%s' (newly created) to '%s'"),
 403                       $newtar, $tarname);
 404         chmod(0666 &~ umask(), $tarname)
 405             or syserr(g_("unable to change permission of '%s'"), $tarname);
 406     } else {
 407         info(g_('building %s using existing %s'),
 408              $sourcepackage, $tarname);
 409     }
 410
 411     $self->add_file($tarname) if $tarname;
 412     # XXX: Re-enable once a stable dpkg supports extracting upstream signatures
 413     # for source 1.0 format, either in 1.17.x or 1.18.x.
 414     #$self->add_file($tarsign) if $tarsign and -e $tarsign;
 415
 416     if ($sourcestyle =~ m/[kpKP]/) {
 417         if (stat($origdir)) {
 418             unless ($sourcestyle =~ m/[KP]/) {
 419                 error(g_("orig directory '%s' already exists, not overwriting, ".
 420                          'giving up; use -sA, -sK or -sP to override'),
 421                       $origdir);
 422             }
 423             push_exit_handler(sub { erasedir($origdir) });
 424             erasedir($origdir);
 425             pop_exit_handler();
 426         } elsif ($! != ENOENT) {
 427             syserr(g_("unable to check for existence of orig directory '%s'"),
 428                     $origdir);
 429         }
 430
 431         my $tar = Dpkg::Source::Archive->new(filename => $origtargz);
 432         $tar->extract($origdir);
 433     }
 434
 435     my $ur; # Unrepresentable changes
 436     if ($sourcestyle =~ m/[kpursKPUR]/) {
 437         my $diffname = "$basenamerev.diff.gz";
 438         info(g_('building %s in %s'),
 439              $sourcepackage, $diffname);
 440         my ($ndfh, $newdiffgz) = tempfile("$diffname.new.XXXXXX",
 441                                         DIR => getcwd(), UNLINK => 0);
 442         push_exit_handler(sub { unlink($newdiffgz) });
 443         my $diff = Dpkg::Source::Patch->new(filename => $newdiffgz,
 444                                             compression => 'gzip',
 445                                             compression_level => $self->{options}{comp_level});
 446         $diff->create();
 447         $diff->add_diff_directory($origdir, $dir,
 448                 basedirname => $basedirname,
 449                 diff_ignore_regex => $diff_ignore_regex,
 450                 options => []); # Force empty set of options to drop the
 451                                 # default -p option
 452         $diff->finish() || $ur++;
 453         pop_exit_handler();
 454
 455         my $analysis = $diff->analyze($origdir);
 456         my @files = grep { ! m{^debian/} }
 457                     map { s{^[^/]+/+}{}r }
 458                     sort keys %{$analysis->{filepatched}};
 459         if (scalar @files) {
 460             warning(g_('the diff modifies the following upstream files: %s'),
 461                     "\n " . join("\n ", @files));
 462             info(g_("use the '3.0 (quilt)' format to have separate and " .
 463                     'documented changes to upstream files, see dpkg-source(1)'));
 464             error(g_('aborting due to --abort-on-upstream-changes'))
 465                 if $self->{options}{abort_on_upstream_changes};
 466         }
 467
 468         rename($newdiffgz, $diffname)
 469             or syserr(g_("unable to rename '%s' (newly created) to '%s'"),
 470                       $newdiffgz, $diffname);
 471         chmod(0666 &~ umask(), $diffname)
 472             or syserr(g_("unable to change permission of '%s'"), $diffname);
 473
 474         $self->add_file($diffname);
 475     }
 476
 477     if ($sourcestyle =~ m/[prPR]/) {
 478         erasedir($origdir);
 479     }
 480
 481     if ($ur) {
 482         errormsg(g_('unrepresentable changes to source'));
 483         exit(1);
 484     }
 485 }
 486
 487 1;