Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | #!/usr/bin/perl |
2 | # | |
3 | # dpkg-source | |
4 | # | |
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> | |
14 | # | |
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. | |
19 | # | |
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. | |
24 | # | |
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/>. | |
27 | ||
28 | use strict; | |
29 | use warnings; | |
30 | ||
31 | use Cwd; | |
32 | use File::Basename; | |
33 | use File::Spec; | |
34 | ||
35 | use Dpkg (); | |
36 | use Dpkg::Gettext; | |
37 | use Dpkg::ErrorHandling; | |
38 | use Dpkg::Util qw(:list); | |
39 | use Dpkg::Arch qw(:operators); | |
40 | use Dpkg::Deps; | |
41 | use Dpkg::Compression; | |
42 | use Dpkg::Conf; | |
43 | use Dpkg::Control::Info; | |
44 | use Dpkg::Control::Tests; | |
45 | use Dpkg::Control::Fields; | |
46 | use Dpkg::Index; | |
47 | use Dpkg::Substvars; | |
48 | use Dpkg::Version; | |
49 | use Dpkg::Vars; | |
50 | use Dpkg::Changelog::Parse; | |
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); | |
55 | ||
56 | textdomain('dpkg-dev'); | |
57 | ||
58 | my $controlfile; | |
59 | my $changelogfile; | |
60 | my $changelogformat; | |
61 | ||
62 | my $build_format; | |
63 | my %options = ( | |
64 | # Ignore files | |
65 | tar_ignore => [], | |
66 | diff_ignore_regex => '', | |
67 | # Misc options | |
68 | copy_orig_tarballs => 1, | |
69 | no_check => 0, | |
70 | no_overwrite_dir => 1, | |
71 | require_valid_signature => 0, | |
72 | require_strong_checksums => 0, | |
73 | ); | |
74 | ||
75 | # Fields to remove/override | |
76 | my %remove; | |
77 | my %override; | |
78 | ||
79 | my $substvars = Dpkg::Substvars->new(); | |
80 | my $tar_ignore_default_pattern_done; | |
81 | my $diff_ignore_regex = get_default_diff_ignore_regex(); | |
82 | ||
83 | my @options; | |
84 | my @cmdline_options; | |
85 | while (@ARGV && $ARGV[0] =~ m/^-/) { | |
86 | my $arg = shift @ARGV; | |
87 | ||
88 | if ($arg eq '-b' or $arg eq '--build') { | |
89 | setopmode('build'); | |
90 | } elsif ($arg eq '-x' or $arg eq '--extract') { | |
91 | setopmode('extract'); | |
92 | } elsif ($arg eq '--before-build') { | |
93 | setopmode('before-build'); | |
94 | } elsif ($arg eq '--after-build') { | |
95 | setopmode('after-build'); | |
96 | } elsif ($arg eq '--commit') { | |
97 | setopmode('commit'); | |
98 | } elsif ($arg eq '--print-format') { | |
99 | setopmode('print-format'); | |
100 | report_options(info_fh => \*STDERR); # Avoid clutter on STDOUT | |
101 | } else { | |
102 | push @options, $arg; | |
103 | } | |
104 | } | |
105 | ||
106 | my $dir; | |
107 | if (defined($options{opmode}) && | |
108 | $options{opmode} =~ /^(build|print-format|(before|after)-build|commit)$/) { | |
109 | if (not scalar(@ARGV)) { | |
110 | usageerr(g_('--%s needs a directory'), $options{opmode}) | |
111 | unless $1 eq 'commit'; | |
112 | $dir = '.'; | |
113 | } else { | |
114 | $dir = File::Spec->catdir(shift(@ARGV)); | |
115 | } | |
116 | stat($dir) or syserr(g_('cannot stat directory %s'), $dir); | |
117 | if (not -d $dir) { | |
118 | error(g_('directory argument %s is not a directory'), $dir); | |
119 | } | |
120 | if ($dir eq '.') { | |
121 | # . is never correct, adjust automatically | |
122 | $dir = basename(cwd()); | |
123 | chdir '..' or syserr(g_("unable to chdir to '%s'"), '..'); | |
124 | } | |
125 | # --format options are not allowed, they would take precedence | |
126 | # over real command line options, debian/source/format should be used | |
127 | # instead | |
128 | # --unapply-patches is only allowed in local-options as it's a matter | |
129 | # of personal taste and the default should be to keep patches applied | |
130 | my $forbidden_opts_re = { | |
131 | 'options' => qr/^--(?:format=|unapply-patches$|abort-on-upstream-changes$)/, | |
132 | 'local-options' => qr/^--format=/, | |
133 | }; | |
134 | foreach my $filename ('local-options', 'options') { | |
135 | my $conf = Dpkg::Conf->new(); | |
136 | my $optfile = File::Spec->catfile($dir, 'debian', 'source', $filename); | |
137 | next unless -f $optfile; | |
138 | $conf->load($optfile); | |
139 | $conf->filter(remove => sub { $_[0] =~ $forbidden_opts_re->{$filename} }); | |
140 | if (@$conf) { | |
141 | info(g_('using options from %s: %s'), $optfile, join(' ', @$conf)) | |
142 | unless $options{opmode} eq 'print-format'; | |
143 | unshift @options, @$conf; | |
144 | } | |
145 | } | |
146 | } | |
147 | ||
148 | while (@options) { | |
149 | $_ = shift(@options); | |
150 | if (m/^--format=(.*)$/) { | |
151 | $build_format //= $1; | |
152 | } elsif (m/^-(?:Z|-compression=)(.*)$/) { | |
153 | my $compression = $1; | |
154 | $options{compression} = $compression; | |
155 | usageerr(g_('%s is not a supported compression'), $compression) | |
156 | unless compression_is_supported($compression); | |
157 | compression_set_default($compression); | |
158 | } elsif (m/^-(?:z|-compression-level=)(.*)$/) { | |
159 | my $comp_level = $1; | |
160 | $options{comp_level} = $comp_level; | |
161 | usageerr(g_('%s is not a compression level'), $comp_level) | |
162 | unless compression_is_valid_level($comp_level); | |
163 | compression_set_default_level($comp_level); | |
164 | } elsif (m/^-c(.*)$/) { | |
165 | $controlfile = $1; | |
166 | } elsif (m/^-l(.*)$/) { | |
167 | $changelogfile = $1; | |
168 | } elsif (m/^-F([0-9a-z]+)$/) { | |
169 | $changelogformat = $1; | |
170 | } elsif (m/^-D([^\=:]+)[=:](.*)$/s) { | |
171 | $override{$1} = $2; | |
172 | } elsif (m/^-U([^\=:]+)$/) { | |
173 | $remove{$1} = 1; | |
174 | } elsif (m/^-(?:i|-diff-ignore(?:$|=))(.*)$/) { | |
175 | $options{diff_ignore_regex} = $1 ? $1 : $diff_ignore_regex; | |
176 | } elsif (m/^--extend-diff-ignore=(.+)$/) { | |
177 | $diff_ignore_regex .= "|$1"; | |
178 | if ($options{diff_ignore_regex}) { | |
179 | $options{diff_ignore_regex} .= "|$1"; | |
180 | } | |
181 | set_default_diff_ignore_regex($diff_ignore_regex); | |
182 | } elsif (m/^-(?:I|-tar-ignore=)(.+)$/) { | |
183 | push @{$options{tar_ignore}}, $1; | |
184 | } elsif (m/^-(?:I|-tar-ignore)$/) { | |
185 | unless ($tar_ignore_default_pattern_done) { | |
186 | push @{$options{tar_ignore}}, get_default_tar_ignore_pattern(); | |
187 | # Prevent adding multiple times | |
188 | $tar_ignore_default_pattern_done = 1; | |
189 | } | |
190 | } elsif (m/^--no-copy$/) { | |
191 | $options{copy_orig_tarballs} = 0; | |
192 | } elsif (m/^--no-check$/) { | |
193 | $options{no_check} = 1; | |
194 | } elsif (m/^--no-overwrite-dir$/) { | |
195 | $options{no_overwrite_dir} = 1; | |
196 | } elsif (m/^--require-valid-signature$/) { | |
197 | $options{require_valid_signature} = 1; | |
198 | } elsif (m/^--require-strong-checksums$/) { | |
199 | $options{require_strong_checksums} = 1; | |
200 | } elsif (m/^-V(\w[-:0-9A-Za-z]*)[=:](.*)$/s) { | |
201 | $substvars->set($1, $2); | |
202 | } elsif (m/^-T(.*)$/) { | |
203 | $substvars->load($1) if -e $1; | |
204 | } elsif (m/^-(?:\?|-help)$/) { | |
205 | usage(); | |
206 | exit(0); | |
207 | } elsif (m/^--version$/) { | |
208 | version(); | |
209 | exit(0); | |
210 | } elsif (m/^-[EW]$/) { | |
211 | # Deprecated option | |
212 | warning(g_('-E and -W are deprecated, they are without effect')); | |
213 | } elsif (m/^-q$/) { | |
214 | report_options(quiet_warnings => 1); | |
215 | $options{quiet} = 1; | |
216 | } elsif (m/^--$/) { | |
217 | last; | |
218 | } else { | |
219 | push @cmdline_options, $_; | |
220 | } | |
221 | } | |
222 | ||
223 | unless (defined($options{opmode})) { | |
224 | usageerr(g_('need an action option')); | |
225 | } | |
226 | ||
227 | if ($options{opmode} =~ /^(build|print-format|(before|after)-build|commit)$/) { | |
228 | ||
229 | $options{ARGV} = \@ARGV; | |
230 | ||
231 | $changelogfile ||= "$dir/debian/changelog"; | |
232 | $controlfile ||= "$dir/debian/control"; | |
233 | ||
234 | my %ch_options = (file => $changelogfile); | |
235 | $ch_options{changelogformat} = $changelogformat if $changelogformat; | |
236 | my $changelog = changelog_parse(%ch_options); | |
237 | my $control = Dpkg::Control::Info->new($controlfile); | |
238 | ||
239 | # <https://reproducible-builds.org/specs/source-date-epoch/> | |
240 | $ENV{SOURCE_DATE_EPOCH} ||= $changelog->{timestamp} || time; | |
241 | ||
242 | my $srcpkg = Dpkg::Source::Package->new(options => \%options); | |
243 | my $fields = $srcpkg->{fields}; | |
244 | ||
245 | my @sourcearch; | |
246 | my %archadded; | |
247 | my @binarypackages; | |
248 | ||
249 | # Scan control info of source package | |
250 | my $src_fields = $control->get_source(); | |
251 | error(g_("%s doesn't contain any information about the source package"), | |
252 | $controlfile) unless defined $src_fields; | |
253 | my $src_sect = $src_fields->{'Section'} || 'unknown'; | |
254 | my $src_prio = $src_fields->{'Priority'} || 'unknown'; | |
255 | foreach (keys %{$src_fields}) { | |
256 | my $v = $src_fields->{$_}; | |
257 | if (m/^Source$/i) { | |
258 | set_source_package($v); | |
259 | $fields->{$_} = $v; | |
260 | } elsif (m/^Uploaders$/i) { | |
261 | ($fields->{$_} = $v) =~ s/\s*[\r\n]\s*/ /g; # Merge in a single-line | |
262 | } elsif (m/^Build-(?:Depends|Conflicts)(?:-Arch|-Indep)?$/i) { | |
263 | my $dep; | |
264 | my $type = field_get_dep_type($_); | |
265 | $dep = deps_parse($v, build_dep => 1, union => $type eq 'union'); | |
266 | error(g_('error occurred while parsing %s'), $_) unless defined $dep; | |
267 | my $facts = Dpkg::Deps::KnownFacts->new(); | |
268 | $dep->simplify_deps($facts); | |
269 | $dep->sort() if $type eq 'union'; | |
270 | $fields->{$_} = $dep->output(); | |
271 | } else { | |
272 | field_transfer_single($src_fields, $fields); | |
273 | } | |
274 | } | |
275 | ||
276 | # Scan control info of binary packages | |
277 | my @pkglist; | |
278 | foreach my $pkg ($control->get_packages()) { | |
279 | my $p = $pkg->{'Package'}; | |
280 | my $sect = $pkg->{'Section'} || $src_sect; | |
281 | my $prio = $pkg->{'Priority'} || $src_prio; | |
282 | my $type = $pkg->{'Package-Type'} || | |
283 | $pkg->get_custom_field('Package-Type') || 'deb'; | |
284 | my $arch = $pkg->{'Architecture'}; | |
285 | my $profile = $pkg->{'Build-Profiles'}; | |
286 | ||
287 | my $pkg_summary = sprintf('%s %s %s %s', $p, $type, $sect, $prio); | |
288 | ||
289 | $pkg_summary .= ' arch=' . join ',', split /\s+/, $arch; | |
290 | ||
291 | if (defined $profile) { | |
292 | # If the string does not contain brackets then it is using the | |
293 | # old syntax. Emit a fatal error. | |
294 | if ($profile !~ m/^\s*<.*>\s*$/) { | |
295 | error(g_('binary package stanza %s is using an obsolete ' . | |
296 | 'Build-Profiles field syntax'), $p); | |
297 | } | |
298 | ||
299 | # Instead of splitting twice and then joining twice, we just do | |
300 | # simple string replacements: | |
301 | ||
302 | # Remove the enclosing <> | |
303 | $profile =~ s/^\s*<(.*)>\s*$/$1/; | |
304 | # Join lists with a plus (OR) | |
305 | $profile =~ s/>\s+</+/g; | |
306 | # Join their elements with a comma (AND) | |
307 | $profile =~ s/\s+/,/g; | |
308 | $pkg_summary .= " profile=$profile"; | |
309 | } | |
310 | ||
311 | if (defined $pkg->{'Essential'} and $pkg->{'Essential'} eq 'yes') { | |
312 | $pkg_summary .= ' essential=yes'; | |
313 | } | |
314 | ||
315 | push @pkglist, $pkg_summary; | |
316 | push @binarypackages, $p; | |
317 | foreach (keys %{$pkg}) { | |
318 | my $v = $pkg->{$_}; | |
319 | if (m/^Architecture$/) { | |
320 | # Gather all binary architectures in one set. 'any' and 'all' | |
321 | # are special-cased as they need to be the only ones in the | |
322 | # current stanza if present. | |
323 | if (debarch_eq($v, 'any') || debarch_eq($v, 'all')) { | |
324 | push(@sourcearch, $v) unless $archadded{$v}++; | |
325 | } else { | |
326 | for my $a (split(/\s+/, $v)) { | |
327 | error(g_("'%s' is not a legal architecture string"), $a) | |
328 | if debarch_is_illegal($a); | |
329 | error(g_('architecture %s only allowed on its ' . | |
330 | "own (list for package %s is '%s')"), | |
331 | $a, $p, $a) | |
332 | if $a eq 'any' or $a eq 'all'; | |
333 | push(@sourcearch, $a) unless $archadded{$a}++; | |
334 | } | |
335 | } | |
336 | } elsif (m/^Homepage$/) { | |
337 | # Do not overwrite the same field from the source entry | |
338 | } else { | |
339 | field_transfer_single($pkg, $fields); | |
340 | } | |
341 | } | |
342 | } | |
343 | unless (scalar(@pkglist)) { | |
344 | error(g_("%s doesn't list any binary package"), $controlfile); | |
345 | } | |
346 | if (any { $_ eq 'any' } @sourcearch) { | |
347 | # If we encounter one 'any' then the other arches become insignificant | |
348 | # except for 'all' that must also be kept | |
349 | if (any { $_ eq 'all' } @sourcearch) { | |
350 | @sourcearch = qw(any all); | |
351 | } else { | |
352 | @sourcearch = qw(any); | |
353 | } | |
354 | } else { | |
355 | # Minimize arch list, by removing arches already covered by wildcards | |
356 | my @arch_wildcards = grep { debarch_is_wildcard($_) } @sourcearch; | |
357 | my @mini_sourcearch = @arch_wildcards; | |
358 | foreach my $arch (@sourcearch) { | |
359 | if (none { debarch_is($arch, $_) } @arch_wildcards) { | |
360 | push @mini_sourcearch, $arch; | |
361 | } | |
362 | } | |
363 | @sourcearch = @mini_sourcearch; | |
364 | } | |
365 | $fields->{'Architecture'} = join(' ', @sourcearch); | |
366 | $fields->{'Package-List'} = "\n" . join("\n", sort @pkglist); | |
367 | ||
368 | # Check if we have a testsuite, and handle manual and automatic values. | |
369 | set_testsuite_fields($fields, @binarypackages); | |
370 | ||
371 | # Scan fields of dpkg-parsechangelog | |
372 | foreach (keys %{$changelog}) { | |
373 | my $v = $changelog->{$_}; | |
374 | ||
375 | if (m/^Source$/) { | |
376 | set_source_package($v); | |
377 | $fields->{$_} = $v; | |
378 | } elsif (m/^Version$/) { | |
379 | my ($ok, $error) = version_check($v); | |
380 | error($error) unless $ok; | |
381 | $fields->{$_} = $v; | |
382 | } elsif (m/^Binary-Only$/) { | |
383 | error(g_('building source for a binary-only release')) | |
384 | if $v eq 'yes' and $options{opmode} eq 'build'; | |
385 | } elsif (m/^Maintainer$/i) { | |
386 | # Do not replace the field coming from the source entry | |
387 | } else { | |
388 | field_transfer_single($changelog, $fields); | |
389 | } | |
390 | } | |
391 | ||
392 | $fields->{'Binary'} = join(', ', @binarypackages); | |
393 | # Avoid overly long line by splitting over multiple lines | |
394 | if (length($fields->{'Binary'}) > 980) { | |
395 | $fields->{'Binary'} =~ s/(.{0,980}), ?/$1,\n/g; | |
396 | } | |
397 | ||
398 | # Select the format to use | |
399 | if (not defined $build_format) { | |
400 | if (-e "$dir/debian/source/format") { | |
401 | open(my $format_fh, '<', "$dir/debian/source/format") | |
402 | or syserr(g_('cannot read %s'), "$dir/debian/source/format"); | |
403 | $build_format = <$format_fh>; | |
404 | chomp($build_format) if defined $build_format; | |
405 | error(g_('%s is empty'), "$dir/debian/source/format") | |
406 | unless defined $build_format and length $build_format; | |
407 | close($format_fh); | |
408 | } else { | |
409 | warning(g_('no source format specified in %s, ' . | |
410 | 'see dpkg-source(1)'), 'debian/source/format') | |
411 | if $options{opmode} eq 'build'; | |
412 | $build_format = '1.0'; | |
413 | } | |
414 | } | |
415 | $fields->{'Format'} = $build_format; | |
416 | $srcpkg->upgrade_object_type(); # Fails if format is unsupported | |
417 | # Parse command line options | |
418 | $srcpkg->init_options(); | |
419 | $srcpkg->parse_cmdline_options(@cmdline_options); | |
420 | ||
421 | if ($options{opmode} eq 'print-format') { | |
422 | print $fields->{'Format'} . "\n"; | |
423 | exit(0); | |
424 | } elsif ($options{opmode} eq 'before-build') { | |
425 | $srcpkg->before_build($dir); | |
426 | exit(0); | |
427 | } elsif ($options{opmode} eq 'after-build') { | |
428 | $srcpkg->after_build($dir); | |
429 | exit(0); | |
430 | } elsif ($options{opmode} eq 'commit') { | |
431 | $srcpkg->commit($dir); | |
432 | exit(0); | |
433 | } | |
434 | ||
435 | # Verify pre-requisites are met | |
436 | my ($res, $msg) = $srcpkg->can_build($dir); | |
437 | error(g_("can't build with source format '%s': %s"), $build_format, $msg) unless $res; | |
438 | ||
439 | # Only -b left | |
440 | info(g_("using source format '%s'"), $fields->{'Format'}); | |
441 | run_vendor_hook('before-source-build', $srcpkg); | |
442 | # Build the files (.tar.gz, .diff.gz, etc) | |
443 | $srcpkg->build($dir); | |
444 | ||
445 | # Write the .dsc | |
446 | my $dscname = $srcpkg->get_basename(1) . '.dsc'; | |
447 | info(g_('building %s in %s'), get_source_package(), $dscname); | |
448 | $srcpkg->write_dsc(filename => $dscname, | |
449 | remove => \%remove, | |
450 | override => \%override, | |
451 | substvars => $substvars); | |
452 | exit(0); | |
453 | ||
454 | } elsif ($options{opmode} eq 'extract') { | |
455 | ||
456 | # Check command line | |
457 | unless (scalar(@ARGV)) { | |
458 | usageerr(g_('--%s needs at least one argument, the .dsc'), | |
459 | $options{opmode}); | |
460 | } | |
461 | if (scalar(@ARGV) > 2) { | |
462 | usageerr(g_('--%s takes no more than two arguments'), $options{opmode}); | |
463 | } | |
464 | my $dsc = shift(@ARGV); | |
465 | if (-d $dsc) { | |
466 | usageerr(g_('--%s needs the .dsc file as first argument, not a directory'), | |
467 | $options{opmode}); | |
468 | } | |
469 | ||
470 | # Create the object that does everything | |
471 | my $srcpkg = Dpkg::Source::Package->new(filename => $dsc, | |
472 | options => \%options); | |
473 | ||
474 | # Parse command line options | |
475 | $srcpkg->parse_cmdline_options(@cmdline_options); | |
476 | ||
477 | # Decide where to unpack | |
478 | my $newdirectory = $srcpkg->get_basename(); | |
479 | $newdirectory =~ s/_/-/g; | |
480 | if (@ARGV) { | |
481 | $newdirectory = File::Spec->catdir(shift(@ARGV)); | |
482 | if (-e $newdirectory) { | |
483 | error(g_('unpack target exists: %s'), $newdirectory); | |
484 | } | |
485 | } | |
486 | ||
487 | # Various checks before unpacking | |
488 | unless ($options{no_check}) { | |
489 | if ($srcpkg->is_signed()) { | |
490 | $srcpkg->check_signature(); | |
491 | } else { | |
492 | if ($options{require_valid_signature}) { | |
493 | error(g_("%s doesn't contain a valid OpenPGP signature"), $dsc); | |
494 | } else { | |
495 | warning(g_('extracting unsigned source package (%s)'), $dsc); | |
496 | } | |
497 | } | |
498 | $srcpkg->check_checksums(); | |
499 | } | |
500 | ||
501 | # Unpack the source package (delegated to Dpkg::Source::Package::*) | |
502 | info(g_('extracting %s in %s'), $srcpkg->{fields}{'Source'}, $newdirectory); | |
503 | $srcpkg->extract($newdirectory); | |
504 | ||
505 | exit(0); | |
506 | } | |
507 | ||
508 | sub set_testsuite_fields | |
509 | { | |
510 | my ($fields, @binarypackages) = @_; | |
511 | ||
512 | my $testsuite_field = $fields->{'Testsuite'} // ''; | |
513 | my %testsuite = map { $_ => 1 } split /\s*,\s*/, $testsuite_field; | |
514 | if (-e "$dir/debian/tests/control") { | |
515 | error(g_('test control %s is not a regular file'), | |
516 | 'debian/tests/control') unless -f _; | |
517 | $testsuite{autopkgtest} = 1; | |
518 | ||
519 | my $tests = Dpkg::Control::Tests->new(); | |
520 | $tests->load("$dir/debian/tests/control"); | |
521 | ||
522 | set_testsuite_triggers_field($tests, $fields, @binarypackages); | |
523 | } elsif ($testsuite{autopkgtest}) { | |
524 | warning(g_('%s field contains value %s, but no tests control file %s'), | |
525 | 'Testsuite', 'autopkgtest', 'debian/tests/control'); | |
526 | delete $testsuite{autopkgtest}; | |
527 | } | |
528 | $fields->{'Testsuite'} = join ', ', sort keys %testsuite; | |
529 | } | |
530 | ||
531 | sub set_testsuite_triggers_field | |
532 | { | |
533 | my ($tests, $fields, @binarypackages) = @_; | |
534 | my %testdeps; | |
535 | ||
536 | # Never overwrite a manually defined field. | |
537 | return if $fields->{'Testsuite-Triggers'}; | |
538 | ||
539 | foreach my $test ($tests->get()) { | |
540 | next unless $test->{Depends}; | |
541 | ||
542 | my $deps = deps_parse($test->{Depends}, use_arch => 0, tests_dep => 1); | |
543 | deps_iterate($deps, sub { $testdeps{$_[0]->{package}} = 1 }); | |
544 | } | |
545 | ||
546 | # Remove our own binaries and meta-depends. | |
547 | foreach my $pkg (@binarypackages, qw(@ @builddeps@)) { | |
548 | delete $testdeps{$pkg}; | |
549 | } | |
550 | $fields->{'Testsuite-Triggers'} = join ', ', sort keys %testdeps; | |
551 | } | |
552 | ||
553 | sub setopmode { | |
554 | my $opmode = shift; | |
555 | ||
556 | if (defined($options{opmode})) { | |
557 | usageerr(g_('two commands specified: --%s and --%s'), | |
558 | $options{opmode}, $opmode); | |
559 | } | |
560 | $options{opmode} = $opmode; | |
561 | } | |
562 | ||
563 | sub print_option { | |
564 | my $opt = shift; | |
565 | my $help; | |
566 | ||
567 | if (length $opt->{name} > 25) { | |
568 | $help .= sprintf " %-25s\n%s%s.\n", $opt->{name}, ' ' x 27, $opt->{help}; | |
569 | } else { | |
570 | $help .= sprintf " %-25s%s.\n", $opt->{name}, $opt->{help}; | |
571 | } | |
572 | } | |
573 | ||
574 | sub get_format_help { | |
575 | $build_format //= '1.0'; | |
576 | ||
577 | my $srcpkg = Dpkg::Source::Package->new(); | |
578 | $srcpkg->{fields}->{'Format'} = $build_format; | |
579 | $srcpkg->upgrade_object_type(); # Fails if format is unsupported | |
580 | ||
581 | my @cmdline = $srcpkg->describe_cmdline_options(); | |
582 | ||
583 | my $help_build = my $help_extract = ''; | |
584 | my $help; | |
585 | ||
586 | foreach my $opt (@cmdline) { | |
587 | $help_build .= print_option($opt) if $opt->{when} eq 'build'; | |
588 | $help_extract .= print_option($opt) if $opt->{when} eq 'extract'; | |
589 | } | |
590 | ||
591 | if ($help_build) { | |
592 | $help .= "\n"; | |
593 | $help .= "Build format $build_format options:\n"; | |
594 | $help .= $help_build || C_('source options', '<none>'); | |
595 | } | |
596 | if ($help_extract) { | |
597 | $help .= "\n"; | |
598 | $help .= "Extract format $build_format options:\n"; | |
599 | $help .= $help_extract || C_('source options', '<none>'); | |
600 | } | |
601 | ||
602 | return $help; | |
603 | } | |
604 | ||
605 | sub version { | |
606 | printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION; | |
607 | ||
608 | print g_(' | |
609 | This is free software; see the GNU General Public License version 2 or | |
610 | later for copying conditions. There is NO warranty. | |
611 | '); | |
612 | } | |
613 | ||
614 | sub usage { | |
615 | printf g_( | |
616 | 'Usage: %s [<option>...] <command>') | |
617 | . "\n\n" . g_( | |
618 | 'Commands: | |
619 | -x, --extract <filename>.dsc [<output-dir>] | |
620 | extract source package. | |
621 | -b, --build <dir> build source package. | |
622 | --print-format <dir> print the format to be used for the source package. | |
623 | --before-build <dir> run the corresponding source package format hook. | |
624 | --after-build <dir> run the corresponding source package format hook. | |
625 | --commit [<dir> [<patch-name>]] | |
626 | store upstream changes in a new patch.') | |
627 | . "\n\n" . g_( | |
628 | "Build options: | |
629 | -c<control-file> get control info from this file. | |
630 | -l<changelog-file> get per-version info from this file. | |
631 | -F<changelog-format> force changelog format. | |
632 | --format=<source-format> set the format to be used for the source package. | |
633 | -V<name>=<value> set a substitution variable. | |
634 | -T<substvars-file> read variables here. | |
635 | -D<field>=<value> override or add a .dsc field and value. | |
636 | -U<field> remove a field. | |
637 | -i, --diff-ignore[=<regex>] | |
638 | filter out files to ignore diffs of | |
639 | (defaults to: '%s'). | |
640 | -I, --tar-ignore[=<pattern>] | |
641 | filter out files when building tarballs | |
642 | (defaults to: %s). | |
643 | -Z, --compression=<compression> | |
644 | select compression to use (defaults to '%s', | |
645 | supported are: %s). | |
646 | -z, --compression-level=<level> | |
647 | compression level to use (defaults to '%d', | |
648 | supported are: '1'-'9', 'best', 'fast')") | |
649 | . "\n\n" . g_( | |
650 | "Extract options: | |
651 | --no-copy don't copy .orig tarballs | |
652 | --no-check don't check signature and checksums before unpacking | |
653 | --no-overwrite-dir do not overwrite directory on extraction | |
654 | --require-valid-signature abort if the package doesn't have a valid signature | |
655 | --require-strong-checksums | |
656 | abort if the package contains no strong checksums | |
657 | --ignore-bad-version allow bad source package versions.") | |
658 | . "\n" . | |
659 | get_format_help() | |
660 | . "\n" . g_( | |
661 | 'General options: | |
662 | -q quiet mode. | |
663 | -?, --help show this help message. | |
664 | --version show the version.') | |
665 | . "\n\n" . g_( | |
666 | 'Source format specific build and extract options are available; | |
667 | use --format with --help to see them.') . "\n", | |
668 | $Dpkg::PROGNAME, | |
669 | get_default_diff_ignore_regex(), | |
670 | join(' ', map { "-I$_" } get_default_tar_ignore_pattern()), | |
671 | compression_get_default(), | |
672 | join(' ', compression_get_list()), | |
673 | compression_get_default_level(); | |
674 | } |