5 # Copyright © 1996 Ian Jackson <ijackson@chiark.greenend.org.uk>
6 # Copyright © 1997 Klee Dienes <klee@debian.org>
7 # Copyright © 1999-2003 Wichert Akkerman <wakkerma@debian.org>
8 # Copyright © 1999 Ben Collins <bcollins@debian.org>
9 # Copyright © 2000-2003 Adam Heath <doogie@debian.org>
10 # Copyright © 2005 Brendan O'Dea <bod@debian.org>
11 # Copyright © 2006-2008 Frank Lichtenheld <djpig@debian.org>
12 # Copyright © 2006-2009,2012 Guillem Jover <guillem@debian.org>
13 # Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org>
15 # This program is free software; you can redistribute it and/or modify
16 # it under the terms of the GNU General Public License as published by
17 # the Free Software Foundation; either version 2 of the License, or
18 # (at your option) any later version.
20 # This program is distributed in the hope that it will be useful,
21 # but WITHOUT ANY WARRANTY; without even the implied warranty of
22 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 # GNU General Public License for more details.
25 # You should have received a copy of the GNU General Public License
26 # along with this program. If not, see <https://www.gnu.org/licenses/>.
31 use List
::Util
qw(any none);
38 use Dpkg
::ErrorHandling
;
39 use Dpkg
::Arch
qw(:operators);
41 use Dpkg
::Compression
;
43 use Dpkg
::Control
::Info
;
44 use Dpkg
::Control
::Tests
;
45 use Dpkg
::Control
::Fields
;
49 use Dpkg
::Changelog
::Parse
;
50 use Dpkg
::Source
::Format
;
51 use Dpkg
::Source
::Package
qw(get_default_diff_ignore_regex
52 set_default_diff_ignore_regex
53 get_default_tar_ignore_pattern);
54 use Dpkg
::Vendor
qw(run_vendor_hook);
56 textdomain
('dpkg-dev');
65 diff_ignore_regex
=> '',
67 copy_orig_tarballs
=> 1,
69 no_overwrite_dir
=> 1,
70 require_valid_signature
=> 0,
71 require_strong_checksums
=> 0,
74 # Fields to remove/override
78 my $substvars = Dpkg
::Substvars
->new();
79 my $tar_ignore_default_pattern_done;
80 my $diff_ignore_regex = get_default_diff_ignore_regex
();
84 while (@ARGV && $ARGV[0] =~ m/^-/) {
85 my $arg = shift @ARGV;
87 if ($arg eq '-b' or $arg eq '--build') {
89 } elsif ($arg eq '-x' or $arg eq '--extract') {
91 } elsif ($arg eq '--before-build') {
92 setopmode
('before-build');
93 } elsif ($arg eq '--after-build') {
94 setopmode
('after-build');
95 } elsif ($arg eq '--commit') {
97 } elsif ($arg eq '--print-format') {
98 setopmode
('print-format');
99 report_options
(info_fh
=> \
*STDERR
); # Avoid clutter on STDOUT
106 if (defined($options{opmode
}) &&
107 $options{opmode
} =~ /^(build|print-format|(before|after)-build|commit)$/) {
108 if (not scalar(@ARGV)) {
109 usageerr
(g_
('--%s needs a directory'), $options{opmode
})
110 unless $1 eq 'commit';
113 $dir = File
::Spec
->catdir(shift(@ARGV));
115 stat($dir) or syserr
(g_
('cannot stat directory %s'), $dir);
117 error
(g_
('directory argument %s is not a directory'), $dir);
120 # . is never correct, adjust automatically
121 $dir = basename
(getcwd
());
122 chdir '..' or syserr
(g_
("unable to chdir to '%s'"), '..');
124 # --format options are not allowed, they would take precedence
125 # over real command line options, debian/source/format should be used
127 # --unapply-patches is only allowed in local-options as it's a matter
128 # of personal taste and the default should be to keep patches applied
129 my $forbidden_opts_re = {
130 'options' => qr/^--(?:format=|unapply-patches$|abort-on-upstream-changes$)/,
131 'local-options' => qr/^--format=/,
133 foreach my $filename ('local-options', 'options') {
134 my $conf = Dpkg
::Conf
->new();
135 my $optfile = File
::Spec
->catfile($dir, 'debian', 'source', $filename);
136 next unless -f
$optfile;
137 $conf->load($optfile);
138 $conf->filter(remove
=> sub { $_[0] =~ $forbidden_opts_re->{$filename} });
140 info
(g_
('using options from %s: %s'), $optfile, join(' ', @
$conf))
141 unless $options{opmode
} eq 'print-format';
142 unshift @options, @
$conf;
148 $_ = shift(@options);
149 if (m/^--format=(.*)$/) {
150 $build_format //= $1;
151 } elsif (m/^-(?:Z|-compression=)(.*)$/) {
152 my $compression = $1;
153 $options{compression
} = $compression;
154 usageerr
(g_
('%s is not a supported compression'), $compression)
155 unless compression_is_supported
($compression);
156 compression_set_default
($compression);
157 } elsif (m/^-(?:z|-compression-level=)(.*)$/) {
159 $options{comp_level
} = $comp_level;
160 usageerr
(g_
('%s is not a compression level'), $comp_level)
161 unless compression_is_valid_level
($comp_level);
162 compression_set_default_level
($comp_level);
163 } elsif (m/^-c(.*)$/) {
165 } elsif (m/^-l(.*)$/) {
166 $options{changelog_file
} = $1;
167 } elsif (m/^-F([0-9a-z]+)$/) {
168 $changelogformat = $1;
169 } elsif (m/^-D([^\=:]+)[=:](.*)$/s) {
171 } elsif (m/^-U([^\=:]+)$/) {
173 } elsif (m/^--diff-ignore$/) {
174 $options{diff_ignore_regex
} = $diff_ignore_regex;
175 } elsif (m/^-(?:i|-diff-ignore=)(.*)$/) {
176 $options{diff_ignore_regex
} = $1 ?
$1 : $diff_ignore_regex;
177 } elsif (m/^--extend-diff-ignore=(.+)$/) {
178 $diff_ignore_regex .= "|$1";
179 if ($options{diff_ignore_regex
}) {
180 $options{diff_ignore_regex
} .= "|$1";
182 set_default_diff_ignore_regex
($diff_ignore_regex);
183 } elsif (m/^-(?:I|-tar-ignore=)(.+)$/) {
184 push @
{$options{tar_ignore
}}, $1;
185 } elsif (m/^-(?:I|-tar-ignore)$/) {
186 unless ($tar_ignore_default_pattern_done) {
187 push @
{$options{tar_ignore
}}, get_default_tar_ignore_pattern
();
188 # Prevent adding multiple times
189 $tar_ignore_default_pattern_done = 1;
191 } elsif (m/^--no-copy$/) {
192 $options{copy_orig_tarballs
} = 0;
193 } elsif (m/^--no-check$/) {
194 $options{no_check
} = 1;
195 } elsif (m/^--no-overwrite-dir$/) {
196 $options{no_overwrite_dir
} = 1;
197 } elsif (m/^--require-valid-signature$/) {
198 $options{require_valid_signature
} = 1;
199 } elsif (m/^--require-strong-checksums$/) {
200 $options{require_strong_checksums
} = 1;
201 } elsif (m/^-V(\w[-:0-9A-Za-z]*)[=:](.*)$/s) {
202 $substvars->set($1, $2);
203 } elsif (m/^-T(.*)$/) {
204 $substvars->load($1) if -e
$1;
205 } elsif (m/^-(?:\?|-help)$/) {
208 } elsif (m/^--version$/) {
211 } elsif (m/^-[EW]$/) {
213 warning
(g_
('-E and -W are deprecated, they are without effect'));
215 report_options
(quiet_warnings
=> 1);
220 push @cmdline_options, $_;
224 unless (defined($options{opmode
})) {
225 usageerr
(g_
('need an action option'));
228 if ($options{opmode
} =~ /^(build|print-format|(before|after)-build|commit)$/) {
230 $options{ARGV
} = \
@ARGV;
232 $options{changelog_file
} ||= "$dir/debian/changelog";
233 $controlfile ||= "$dir/debian/control";
235 my %ch_options = (file
=> $options{changelog_file
});
236 $ch_options{changelogformat
} = $changelogformat if $changelogformat;
237 my $changelog = changelog_parse
(%ch_options);
238 my $control = Dpkg
::Control
::Info
->new($controlfile);
240 # <https://reproducible-builds.org/specs/source-date-epoch/>
241 $ENV{SOURCE_DATE_EPOCH
} ||= $changelog->{timestamp
} || time;
243 # Select the format to use
244 if (not defined $build_format) {
245 my $format_file = "$dir/debian/source/format";
246 if (-e
$format_file) {
247 my $format = Dpkg
::Source
::Format
->new(filename
=> $format_file);
248 $build_format = $format->get();
250 warning
(g_
('no source format specified in %s, ' .
251 'see dpkg-source(1)'), 'debian/source/format')
252 if $options{opmode
} eq 'build';
253 $build_format = '1.0';
257 my $srcpkg = Dpkg
::Source
::Package
->new(format
=> $build_format,
258 options
=> \
%options);
259 my $fields = $srcpkg->{fields
};
261 $srcpkg->parse_cmdline_options(@cmdline_options);
267 # Scan control info of source package
268 my $src_fields = $control->get_source();
269 error
(g_
("%s doesn't contain any information about the source package"),
270 $controlfile) unless defined $src_fields;
271 my $src_sect = $src_fields->{'Section'} || 'unknown';
272 my $src_prio = $src_fields->{'Priority'} || 'unknown';
273 foreach (keys %{$src_fields}) {
274 my $v = $src_fields->{$_};
276 set_source_package
($v);
278 } elsif (m/^Uploaders$/i) {
279 ($fields->{$_} = $v) =~ s/\s*[\r\n]\s*/ /g; # Merge in a single-line
280 } elsif (m/^Build-(?:Depends|Conflicts)(?:-Arch|-Indep)?$/i) {
282 my $type = field_get_dep_type
($_);
283 $dep = deps_parse
($v, build_dep
=> 1, union
=> $type eq 'union');
284 error
(g_
('cannot parse %s field'), $_) unless defined $dep;
285 my $facts = Dpkg
::Deps
::KnownFacts
->new();
286 $dep->simplify_deps($facts);
287 $dep->sort() if $type eq 'union';
288 $fields->{$_} = $dep->output();
290 field_transfer_single
($src_fields, $fields);
294 # Scan control info of binary packages
296 foreach my $pkg ($control->get_packages()) {
297 my $p = $pkg->{'Package'};
298 my $sect = $pkg->{'Section'} || $src_sect;
299 my $prio = $pkg->{'Priority'} || $src_prio;
300 my $type = $pkg->{'Package-Type'} ||
301 $pkg->get_custom_field('Package-Type') || 'deb';
302 my $arch = $pkg->{'Architecture'};
303 my $profile = $pkg->{'Build-Profiles'};
305 my $pkg_summary = sprintf('%s %s %s %s', $p, $type, $sect, $prio);
307 $pkg_summary .= ' arch=' . join ',', split ' ', $arch;
309 if (defined $profile) {
310 # Instead of splitting twice and then joining twice, we just do
311 # simple string replacements:
313 # Remove the enclosing <>
314 $profile =~ s/^\s*<(.*)>\s*$/$1/;
315 # Join lists with a plus (OR)
316 $profile =~ s/>\s+</+/g;
317 # Join their elements with a comma (AND)
318 $profile =~ s/\s+/,/g;
319 $pkg_summary .= " profile=$profile";
321 if (defined $pkg->{'Protected'} and $pkg->{'Protected'} eq 'yes') {
322 $pkg_summary .= ' protected=yes';
324 if (defined $pkg->{'Essential'} and $pkg->{'Essential'} eq 'yes') {
325 $pkg_summary .= ' essential=yes';
328 push @pkglist, $pkg_summary;
329 push @binarypackages, $p;
330 foreach (keys %{$pkg}) {
332 if (m/^Architecture$/) {
333 # Gather all binary architectures in one set. 'any' and 'all'
334 # are special-cased as they need to be the only ones in the
335 # current stanza if present.
336 if (debarch_eq
($v, 'any') || debarch_eq
($v, 'all')) {
337 push(@sourcearch, $v) unless $archadded{$v}++;
339 for my $a (split(/\s+/, $v)) {
340 error
(g_
("'%s' is not a legal architecture string " .
341 "in package '%s'"), $a, $p)
342 if debarch_is_illegal
($a);
343 error
(g_
('architecture %s only allowed on its ' .
344 "own (list for package %s is '%s')"),
346 if $a eq 'any' or $a eq 'all';
347 push(@sourcearch, $a) unless $archadded{$a}++;
350 } elsif (m/^(?:Homepage|Description)$/) {
351 # Do not overwrite the same field from the source entry
353 field_transfer_single
($pkg, $fields);
357 unless (scalar(@pkglist)) {
358 error
(g_
("%s doesn't list any binary package"), $controlfile);
360 if (any
{ $_ eq 'any' } @sourcearch) {
361 # If we encounter one 'any' then the other arches become insignificant
362 # except for 'all' that must also be kept
363 if (any
{ $_ eq 'all' } @sourcearch) {
364 @sourcearch = qw(any all);
366 @sourcearch = qw(any);
369 # Minimize arch list, by removing arches already covered by wildcards
370 my @arch_wildcards = grep { debarch_is_wildcard
($_) } @sourcearch;
371 my @mini_sourcearch = @arch_wildcards;
372 foreach my $arch (@sourcearch) {
373 if (none
{ debarch_is
($arch, $_) } @arch_wildcards) {
374 push @mini_sourcearch, $arch;
377 @sourcearch = @mini_sourcearch;
379 $fields->{'Architecture'} = join(' ', @sourcearch);
380 $fields->{'Package-List'} = "\n" . join("\n", sort @pkglist);
382 # Check if we have a testsuite, and handle manual and automatic values.
383 set_testsuite_fields
($fields, @binarypackages);
385 # Scan fields of dpkg-parsechangelog
386 foreach (keys %{$changelog}) {
387 my $v = $changelog->{$_};
390 set_source_package
($v);
392 } elsif (m/^Version$/) {
393 my ($ok, $error) = version_check
($v);
394 error
($error) unless $ok;
396 } elsif (m/^Binary-Only$/) {
397 error
(g_
('building source for a binary-only release'))
398 if $v eq 'yes' and $options{opmode
} eq 'build';
399 } elsif (m/^Maintainer$/i) {
400 # Do not replace the field coming from the source entry
402 field_transfer_single
($changelog, $fields);
406 $fields->{'Binary'} = join(', ', @binarypackages);
407 # Avoid overly long line by splitting over multiple lines
408 if (length($fields->{'Binary'}) > 980) {
409 $fields->{'Binary'} =~ s/(.{0,980}), ?/$1,\n/g;
412 if ($options{opmode
} eq 'print-format') {
413 print $fields->{'Format'} . "\n";
415 } elsif ($options{opmode
} eq 'before-build') {
416 $srcpkg->before_build($dir);
418 } elsif ($options{opmode
} eq 'after-build') {
419 $srcpkg->after_build($dir);
421 } elsif ($options{opmode
} eq 'commit') {
422 $srcpkg->commit($dir);
426 # Verify pre-requisites are met
427 my ($res, $msg) = $srcpkg->can_build($dir);
428 error
(g_
("can't build with source format '%s': %s"), $build_format, $msg) unless $res;
431 info
(g_
("using source format '%s'"), $fields->{'Format'});
432 run_vendor_hook
('before-source-build', $srcpkg);
433 # Build the files (.tar.gz, .diff.gz, etc)
434 $srcpkg->build($dir);
437 my $dscname = $srcpkg->get_basename(1) . '.dsc';
438 info
(g_
('building %s in %s'), get_source_package
(), $dscname);
439 $srcpkg->write_dsc(filename
=> $dscname,
441 override
=> \
%override,
442 substvars
=> $substvars);
445 } elsif ($options{opmode
} eq 'extract') {
448 unless (scalar(@ARGV)) {
449 usageerr
(g_
('--%s needs at least one argument, the .dsc'),
452 if (scalar(@ARGV) > 2) {
453 usageerr
(g_
('--%s takes no more than two arguments'), $options{opmode
});
455 my $dsc = shift(@ARGV);
457 usageerr
(g_
('--%s needs the .dsc file as first argument, not a directory'),
461 # Create the object that does everything
462 my $srcpkg = Dpkg
::Source
::Package
->new(filename
=> $dsc,
463 options
=> \
%options);
465 # Parse command line options
466 $srcpkg->parse_cmdline_options(@cmdline_options);
468 # Decide where to unpack
469 my $newdirectory = $srcpkg->get_basename();
470 $newdirectory =~ s/_/-/g;
472 $newdirectory = File
::Spec
->catdir(shift(@ARGV));
473 if (-e
$newdirectory) {
474 error
(g_
('unpack target exists: %s'), $newdirectory);
478 # Various checks before unpacking
479 unless ($options{no_check
}) {
480 if ($srcpkg->is_signed()) {
481 $srcpkg->check_signature();
483 if ($options{require_valid_signature
}) {
484 error
(g_
("%s doesn't contain a valid OpenPGP signature"), $dsc);
486 warning
(g_
('extracting unsigned source package (%s)'), $dsc);
489 $srcpkg->check_checksums();
492 # Unpack the source package (delegated to Dpkg::Source::Package::*)
493 info
(g_
('extracting %s in %s'), $srcpkg->{fields
}{'Source'}, $newdirectory);
494 $srcpkg->extract($newdirectory);
499 sub set_testsuite_fields
501 my ($fields, @binarypackages) = @_;
503 my $testsuite_field = $fields->{'Testsuite'} // '';
504 my %testsuite = map { $_ => 1 } split /\s*,\s*/, $testsuite_field;
505 if (-e
"$dir/debian/tests/control") {
506 error
(g_
('test control %s is not a regular file'),
507 'debian/tests/control') unless -f _
;
508 $testsuite{autopkgtest
} = 1;
510 my $tests = Dpkg
::Control
::Tests
->new();
511 $tests->load("$dir/debian/tests/control");
513 set_testsuite_triggers_field
($tests, $fields, @binarypackages);
514 } elsif ($testsuite{autopkgtest
}) {
515 warning
(g_
('%s field contains value %s, but no tests control file %s'),
516 'Testsuite', 'autopkgtest', 'debian/tests/control');
517 delete $testsuite{autopkgtest
};
519 $fields->{'Testsuite'} = join ', ', sort keys %testsuite;
522 sub set_testsuite_triggers_field
524 my ($tests, $fields, @binarypackages) = @_;
527 # Never overwrite a manually defined field.
528 return if $fields->{'Testsuite-Triggers'};
530 foreach my $test ($tests->get()) {
531 if (not exists $test->{Tests
} and not exists $test->{'Test-Command'}) {
532 error
(g_
('test control %s is missing %s or %s field'),
533 'debian/tests/control', 'Tests', 'Test-Command');
536 next unless $test->{Depends
};
538 my $deps = deps_parse
($test->{Depends
}, use_arch
=> 0, tests_dep
=> 1);
539 deps_iterate
($deps, sub { $testdeps{$_[0]->{package}} = 1 });
542 # Remove our own binaries and its meta-depends variant.
543 foreach my $pkg (@binarypackages, qw(@)) {
544 delete $testdeps{$pkg};
546 $fields->{'Testsuite-Triggers'} = join ', ', sort keys %testdeps;
552 if (defined($options{opmode
})) {
553 usageerr
(g_
('two commands specified: --%s and --%s'),
554 $options{opmode
}, $opmode);
556 $options{opmode
} = $opmode;
563 if (length $opt->{name
} > 25) {
564 $help .= sprintf " %-25s\n%s%s.\n", $opt->{name
}, ' ' x
27, $opt->{help
};
566 $help .= sprintf " %-25s%s.\n", $opt->{name
}, $opt->{help
};
570 sub get_format_help
{
571 $build_format //= '1.0';
573 my $srcpkg = Dpkg
::Source
::Package
->new(format
=> $build_format);
575 my @cmdline = $srcpkg->describe_cmdline_options();
576 return '' unless @cmdline;
578 my $help_build = my $help_extract = '';
581 foreach my $opt (@cmdline) {
582 $help_build .= print_option
($opt) if $opt->{when} eq 'build';
583 $help_extract .= print_option
($opt) if $opt->{when} eq 'extract';
588 $help .= "Build format $build_format options:\n";
589 $help .= $help_build || C_
('source options', '<none>');
593 $help .= "Extract format $build_format options:\n";
594 $help .= $help_extract || C_
('source options', '<none>');
601 printf g_
("Debian %s version %s.\n"), $Dpkg::PROGNAME
, $Dpkg::PROGVERSION
;
604 This is free software; see the GNU General Public License version 2 or
605 later for copying conditions. There is NO warranty.
611 'Usage: %s [<option>...] <command>')
614 -x, --extract <filename>.dsc [<output-dir>]
615 extract source package.
616 -b, --build <dir> build source package.
617 --print-format <dir> print the format to be used for the source package.
618 --before-build <dir> run the corresponding source package format hook.
619 --after-build <dir> run the corresponding source package format hook.
620 --commit [<dir> [<patch-name>]]
621 store upstream changes in a new patch.')
624 -c<control-file> get control info from this file.
625 -l<changelog-file> get per-version info from this file.
626 -F<changelog-format> force changelog format.
627 --format=<source-format> set the format to be used for the source package.
628 -V<name>=<value> set a substitution variable.
629 -T<substvars-file> read variables here.
630 -D<field>=<value> override or add a .dsc field and value.
631 -U<field> remove a field.
632 -i, --diff-ignore[=<regex>]
633 filter out files to ignore diffs of
635 -I, --tar-ignore[=<pattern>]
636 filter out files when building tarballs
638 -Z, --compression=<compression>
639 select compression to use (defaults to '%s',
641 -z, --compression-level=<level>
642 compression level to use (defaults to '%d',
643 supported are: '1'-'9', 'best', 'fast')")
646 --no-copy don't copy .orig tarballs
647 --no-check don't check signature and checksums before unpacking
648 --no-overwrite-dir do not overwrite directory on extraction
649 --require-valid-signature abort if the package doesn't have a valid signature
650 --require-strong-checksums
651 abort if the package contains no strong checksums
652 --ignore-bad-version allow bad source package versions.")
658 -?, --help show this help message.
659 --version show the version.')
661 'Source format specific build and extract options are available;
662 use --format with --help to see them.') . "\n",
664 get_default_diff_ignore_regex
(),
665 join(' ', map { "-I$_" } get_default_tar_ignore_pattern
()),
666 compression_get_default
(),
667 join(' ', compression_get_list
()),
668 compression_get_default_level
();