scripts/dpkg-source.pl

   1 #! /usr/bin/perl
   2 # vim: set et sw=4 ts=8
   3 #
   4 # dpkg-source
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 use strict;
  20 use warnings;
  21
  22 use Dpkg;
  23 use Dpkg::Gettext;
  24 use Dpkg::ErrorHandling;
  25 use Dpkg::Arch qw(debarch_eq);
  26 use Dpkg::Deps;
  27 use Dpkg::Compression;
  28 use Dpkg::Conf;
  29 use Dpkg::Control::Info;
  30 use Dpkg::Control::Fields;
  31 use Dpkg::Substvars;
  32 use Dpkg::Version;
  33 use Dpkg::Vars;
  34 use Dpkg::Changelog::Parse;
  35 use Dpkg::Source::Compressor;
  36 use Dpkg::Source::Package;
  37 use Dpkg::Vendor qw(run_vendor_hook);
  38
  39 use File::Spec;
  40
  41 textdomain("dpkg-dev");
  42
  43 my $varlistfile;
  44 my $controlfile;
  45 my $changelogfile;
  46 my $changelogformat;
  47
  48 my @build_formats = ("1.0", "3.0 (quilt)", "3.0 (native)");
  49 my %options = (
  50     # Compression related
  51     compression => $Dpkg::Source::Compressor::default_compression,
  52     comp_level => $Dpkg::Source::Compressor::default_compression_level,
  53     comp_ext => $comp_ext{$Dpkg::Source::Compressor::default_compression},
  54     # Ignore files
  55     tar_ignore => [],
  56     diff_ignore_regexp => '',
  57     # Misc options
  58     copy_orig_tarballs => 1,
  59     no_check => 0,
  60     require_valid_signature => 0,
  61 );
  62
  63 # Fields to remove/override
  64 my %remove;
  65 my %override;
  66
  67 my $substvars = Dpkg::Substvars->new();
  68 my $tar_ignore_default_pattern_done;
  69
  70 my @options;
  71 my @cmdline_options;
  72 my @cmdline_formats;
  73 while (@ARGV && $ARGV[0] =~ m/^-/) {
  74     $_ = shift(@ARGV);
  75     if (m/^-b$/) {
  76         setopmode('-b');
  77     } elsif (m/^-x$/) {
  78         setopmode('-x');
  79     } elsif (m/^--print-format$/) {
  80         setopmode('--print-format');
  81     } else {
  82         push @options, $_;
  83     }
  84 }
  85
  86 my $dir;
  87 if (defined($options{'opmode'}) &&
  88     $options{'opmode'} =~ /^(-b|--print-format)$/) {
  89     if (not scalar(@ARGV)) {
  90         usageerr(_g("%s needs a directory"), $options{'opmode'});
  91     }
  92     $dir = File::Spec->catdir(shift(@ARGV));
  93     stat($dir) || syserr(_g("cannot stat directory %s"), $dir);
  94     if (not -d $dir) {
  95         error(_g("directory argument %s is not a directory"), $dir);
  96     }
  97     my $conf = Dpkg::Conf->new();
  98     my $optfile = File::Spec->catfile($dir, "debian", "source", "options");
  99     $conf->load($optfile) if -f $optfile;
 100     # --format options are not allowed, they would take precedence
 101     # over real command line options, debian/source/format should be used
 102     # instead
 103     @$conf = grep { ! /^--format=/ } @$conf;
 104     if (@$conf) {
 105         info(_g("using options from %s: %s"), $optfile, "$conf")
 106             unless $options{'opmode'} eq "--print-format";
 107         unshift @options, @$conf;
 108     }
 109 }
 110
 111 while (@options) {
 112     $_ = shift(@options);
 113     if (m/^--format=(.*)$/) {
 114         push @cmdline_formats, $1;
 115     } elsif (m/^-(?:Z|-compression=)(.*)$/) {
 116         my $compression = $1;
 117         $options{'compression'} = $compression;
 118         $options{'comp_ext'} = $comp_ext{$compression};
 119         usageerr(_g("%s is not a supported compression"), $compression)
 120             unless $comp_supported{$compression};
 121         Dpkg::Source::Compressor->set_default_compression($compression);
 122     } elsif (m/^-(?:z|-compression-level=)(.*)$/) {
 123         my $comp_level = $1;
 124         $options{'comp_level'} = $comp_level;
 125         usageerr(_g("%s is not a compression level"), $comp_level)
 126             unless $comp_level =~ /^([1-9]|fast|best)$/;
 127         Dpkg::Source::Compressor->set_default_compression_level($comp_level);
 128     } elsif (m/^-c(.*)$/) {
 129         $controlfile = $1;
 130     } elsif (m/^-l(.*)$/) {
 131         $changelogfile = $1;
 132     } elsif (m/^-F([0-9a-z]+)$/) {
 133         $changelogformat = $1;
 134     } elsif (m/^-D([^\=:]+)[=:](.*)$/) {
 135         $override{$1} = $2;
 136     } elsif (m/^-U([^\=:]+)$/) {
 137         $remove{$1} = 1;
 138     } elsif (m/^-i(.*)$/) {
 139         $options{'diff_ignore_regexp'} = $1 ? $1 : $Dpkg::Source::Package::diff_ignore_default_regexp;
 140     } elsif (m/^-I(.+)$/) {
 141         push @{$options{'tar_ignore'}}, $1;
 142     } elsif (m/^-I$/) {
 143         unless ($tar_ignore_default_pattern_done) {
 144             push @{$options{'tar_ignore'}}, @Dpkg::Source::Package::tar_ignore_default_pattern;
 145             # Prevent adding multiple times
 146             $tar_ignore_default_pattern_done = 1;
 147         }
 148     } elsif (m/^--no-copy$/) {
 149         $options{'copy_orig_tarballs'} = 0;
 150     } elsif (m/^--no-check$/) {
 151         $options{'no_check'} = 1;
 152     } elsif (m/^--require-valid-signature$/) {
 153         $options{'require_valid_signature'} = 1;
 154     } elsif (m/^-V(\w[-:0-9A-Za-z]*)[=:](.*)$/) {
 155         $substvars->set($1, $2);
 156     } elsif (m/^-T(.*)$/) {
 157         $varlistfile = $1;
 158     } elsif (m/^-(h|-help)$/) {
 159         usage();
 160         exit(0);
 161     } elsif (m/^--version$/) {
 162         version();
 163         exit(0);
 164     } elsif (m/^-[EW]$/) {
 165         # Deprecated option
 166         warning(_g("-E and -W are deprecated, they are without effect"));
 167     } elsif (m/^-q$/) {
 168         report_options(quiet_warnings => 1);
 169         $options{'quiet'} = 1;
 170     } elsif (m/^--$/) {
 171         last;
 172     } else {
 173         push @cmdline_options, $_;
 174     }
 175 }
 176
 177 unless (defined($options{'opmode'})) {
 178     usageerr(_g("need -x or -b"));
 179 }
 180
 181 if ($options{'opmode'} =~ /^(-b|--print-format)$/) {
 182
 183     $options{'ARGV'} = \@ARGV;
 184
 185     $changelogfile ||= "$dir/debian/changelog";
 186     $controlfile ||= "$dir/debian/control";
 187
 188     my %ch_options = (file => $changelogfile);
 189     $ch_options{"changelogformat"} = $changelogformat if $changelogformat;
 190     my $changelog = changelog_parse(%ch_options);
 191     my $control = Dpkg::Control::Info->new($controlfile);
 192
 193     my $srcpkg = Dpkg::Source::Package->new(options => \%options);
 194     my $fields = $srcpkg->{'fields'};
 195
 196     my @sourcearch;
 197     my %archadded;
 198     my @binarypackages;
 199
 200     # Scan control info of source package
 201     my $src_fields = $control->get_source();
 202     foreach $_ (keys %{$src_fields}) {
 203         my $v = $src_fields->{$_};
 204         if (m/^Source$/i) {
 205             set_source_package($v);
 206             $fields->{$_} = $v;
 207         } elsif (m/^Uploaders$/i) {
 208             ($fields->{$_} = $v) =~ s/[\r\n]/ /g; # Merge in a single-line
 209         } elsif (m/^Build-(Depends|Conflicts)(-Indep)?$/i) {
 210             my $dep;
 211             my $type = field_get_dep_type($_);
 212             $dep = deps_parse($v, union => $type eq 'union');
 213             error(_g("error occurred while parsing %s"), $_) unless defined $dep;
 214             my $facts = Dpkg::Deps::KnownFacts->new();
 215             $dep->simplify_deps($facts);
 216             $dep->sort() if $type eq 'union';
 217             $fields->{$_} = $dep->output();
 218         } else {
 219             field_transfer_single($src_fields, $fields);
 220         }
 221     }
 222
 223     # Scan control info of binary packages
 224     foreach my $pkg ($control->get_packages()) {
 225         my $p = $pkg->{'Package'};
 226         push(@binarypackages,$p);
 227         foreach $_ (keys %{$pkg}) {
 228             my $v = $pkg->{$_};
 229             if (m/^Architecture$/) {
 230                 # Gather all binary architectures in one set. 'any' and 'all'
 231                 # are special-cased as they need to be the only ones in the
 232                 # current stanza if present.
 233                 if (debarch_eq($v, 'any') || debarch_eq($v, 'all')) {
 234                     push(@sourcearch, $v) unless $archadded{$v}++;
 235                 } else {
 236                     for my $a (split(/\s+/, $v)) {
 237                         error(_g("`%s' is not a legal architecture string"),
 238                               $a)
 239                             unless $a =~ /^[\w-]+$/;
 240                         error(_g("architecture %s only allowed on its " .
 241                                  "own (list for package %s is `%s')"),
 242                               $a, $p, $a)
 243                             if grep($a eq $_, 'any', 'all');
 244                         push(@sourcearch, $a) unless $archadded{$a}++;
 245                     }
 246                 }
 247             } elsif (m/^Homepage$/) {
 248                 # Do not overwrite the same field from the source entry
 249             } else {
 250                 field_transfer_single($pkg, $fields);
 251             }
 252         }
 253     }
 254     if (grep($_ eq 'any', @sourcearch)) {
 255         # If we encounter one 'any' then the other arches become insignificant.
 256         @sourcearch = ('any');
 257     }
 258     $fields->{'Architecture'} = join(' ', @sourcearch);
 259
 260     # Scan fields of dpkg-parsechangelog
 261     foreach $_ (keys %{$changelog}) {
 262         my $v = $changelog->{$_};
 263
 264         if (m/^Source$/) {
 265             set_source_package($v);
 266             $fields->{$_} = $v;
 267         } elsif (m/^Version$/) {
 268             my ($ok, $error) = version_check($v);
 269             error($error) unless $ok;
 270             $fields->{$_} = $v;
 271         } elsif (m/^Maintainer$/i) {
 272             # Do not replace the field coming from the source entry
 273         } else {
 274             field_transfer_single($changelog, $fields);
 275         }
 276     }
 277
 278     $fields->{'Binary'} = join(', ', @binarypackages);
 279     # Avoid overly long line (>~1000 chars) by splitting over multiple lines
 280     $fields->{'Binary'} =~ s/(.{980,}?), ?/$1,\n/g;
 281
 282     # Generate list of formats to try
 283     my @try_formats = (@cmdline_formats);
 284     if (-e "$dir/debian/source/format") {
 285         open(FORMAT, "<", "$dir/debian/source/format") ||
 286             syserr(_g("cannot read %s"), "$dir/debian/source/format");
 287         my $format = <FORMAT>;
 288         chomp($format);
 289         close(FORMAT);
 290         push @try_formats, $format;
 291     }
 292     push @try_formats, @build_formats;
 293     # Try all suggested formats until one is acceptable
 294     foreach my $format (@try_formats) {
 295         $fields->{'Format'} = $format;
 296         $srcpkg->upgrade_object_type(); # Fails if format is unsupported
 297         my ($res, $msg) = $srcpkg->can_build($dir);
 298         last if $res;
 299         info(_g("source format `%s' discarded: %s"), $format, $msg)
 300             unless $options{'opmode'} eq "--print-format";
 301     }
 302     if ($options{'opmode'} eq "--print-format") {
 303         print $fields->{'Format'} . "\n";
 304         exit(0);
 305     }
 306     info(_g("using source format `%s'"), $fields->{'Format'});
 307
 308     # Parse command line options
 309     $srcpkg->init_options();
 310     $srcpkg->parse_cmdline_options(@cmdline_options);
 311
 312     run_vendor_hook("before-source-build", $srcpkg);
 313     # Build the files (.tar.gz, .diff.gz, etc)
 314     $srcpkg->build($dir);
 315
 316     # Write the .dsc
 317     my $dscname = $srcpkg->get_basename(1) . ".dsc";
 318     info(_g("building %s in %s"), $sourcepackage, $dscname);
 319     $substvars->parse($varlistfile) if $varlistfile && -e $varlistfile;
 320     $srcpkg->write_dsc(filename => $dscname,
 321                        remove => \%remove,
 322                        override => \%override,
 323                        substvars => $substvars);
 324     exit(0);
 325
 326 } elsif ($options{'opmode'} eq '-x') {
 327
 328     # Check command line
 329     unless (scalar(@ARGV)) {
 330         usageerr(_g("-x needs at least one argument, the .dsc"));
 331     }
 332     if (scalar(@ARGV) > 2) {
 333         usageerr(_g("-x takes no more than two arguments"));
 334     }
 335     my $dsc = shift(@ARGV);
 336     if (-d $dsc) {
 337         usageerr(_g("-x needs the .dsc file as first argument, not a directory"));
 338     }
 339
 340     # Create the object that does everything
 341     my $srcpkg = Dpkg::Source::Package->new(filename => $dsc,
 342                                             options => \%options);
 343
 344     # Parse command line options
 345     $srcpkg->parse_cmdline_options(@cmdline_options);
 346
 347     # Decide where to unpack
 348     my $newdirectory = $srcpkg->get_basename();
 349     $newdirectory =~ s/_/-/g;
 350     if (@ARGV) {
 351         $newdirectory = File::Spec->catdir(shift(@ARGV));
 352         if (-e $newdirectory) {
 353             error(_g("unpack target exists: %s"), $newdirectory);
 354         }
 355     }
 356
 357     # Various checks before unpacking
 358     unless ($options{'no_check'}) {
 359         if ($srcpkg->is_signed()) {
 360             $srcpkg->check_signature();
 361         } else {
 362             if ($options{'require_valid_signature'}) {
 363                 error(_g("%s doesn't contain a valid OpenPGP signature"), $dsc);
 364             } else {
 365                 warning(_g("extracting unsigned source package (%s)"), $dsc);
 366             }
 367         }
 368         $srcpkg->check_checksums();
 369     }
 370
 371     # Unpack the source package (delegated to Dpkg::Source::Package::*)
 372     info(_g("extracting %s in %s"), $srcpkg->{'fields'}{'Source'}, $newdirectory);
 373     $srcpkg->extract($newdirectory);
 374
 375     exit(0);
 376 }
 377
 378 sub setopmode {
 379     if (defined($options{'opmode'})) {
 380         usageerr(_g("only one of -x, -b or --print-format allowed, and only once"));
 381     }
 382     $options{'opmode'} = $_[0];
 383 }
 384
 385 sub version {
 386     printf _g("Debian %s version %s.\n"), $progname, $version;
 387
 388     print _g("
 389 Copyright (C) 1996 Ian Jackson and Klee Dienes.
 390 Copyright (C) 2008 Raphael Hertzog");
 391
 392     print _g("
 393 This is free software; see the GNU General Public Licence version 2 or
 394 later for copying conditions. There is NO warranty.
 395 ");
 396 }
 397
 398 sub usage {
 399     printf _g(
 400 "Usage: %s [<option> ...] <command>
 401
 402 Commands:
 403   -x <filename>.dsc [<output-dir>]
 404                            extract source package.
 405   -b <dir>                 build source package.
 406   --print-format <dir>     print the source format that would be
 407                            used to build the source package.")
 408     . "\n\n" . _g(
 409 "Build options:
 410   -c<controlfile>          get control info from this file.
 411   -l<changelogfile>        get per-version info from this file.
 412   -F<changelogformat>      force change log format.
 413   -V<name>=<value>         set a substitution variable.
 414   -T<varlistfile>          read variables here.
 415   -D<field>=<value>        override or add a .dsc field and value.
 416   -U<field>                remove a field.
 417   -q                       quiet mode.
 418   -i[<regexp>]             filter out files to ignore diffs of
 419                              (defaults to: '%s').
 420   -I[<pattern>]            filter out files when building tarballs
 421                              (defaults to: %s).
 422   -Z<compression>          select compression to use (defaults to '%s',
 423                              supported are: %s).
 424   -z<level>                compression level to use (defaults to '%d',
 425                              supported are: '1'-'9', 'best', 'fast')")
 426     . "\n\n" . _g(
 427 "Extract options:
 428   --no-copy                don't copy .orig tarballs
 429   --no-check               don't check signature and checksums before unpacking
 430   --require-valid-signature abort if the package doesn't have a valid signature")
 431     . "\n\n" . _g(
 432 "General options:
 433   -h, --help               show this help message.
 434       --version            show the version.")
 435     . "\n\n" . _g(
 436 "More options are available but they depend on the source package format.
 437 See dpkg-source(1) for more info.") . "\n",
 438     $progname,
 439     $Dpkg::Source::Package::diff_ignore_default_regexp,
 440     join(' ', map { "-I$_" } @Dpkg::Source::Package::tar_ignore_default_pattern),
 441     $Dpkg::Source::Compressor::default_compression, "@comp_supported",
 442     $Dpkg::Source::Compressor::default_compression_level;
 443 }
 444