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