5 # Copyright © 2006-2015 Guillem Jover <guillem@debian.org>
7 # This program is free software; you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 2 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <https://www.gnu.org/licenses/>.
23 use Getopt
::Long
qw(:config posix_default bundling no_ignorecase
);
28 use Dpkg
::ErrorHandling
;
29 use Dpkg
::Util
qw(:list
);
33 use Dpkg
::Compression
::FileHandle
;
35 textdomain
('dpkg-dev');
37 # Do not pollute STDOUT with info messages
38 report_options
(info_fh
=> \
*STDERR
);
40 my (@samemaint, @changedmaint);
46 my %options = (help
=> sub { usage
(); exit 0; },
47 version
=> sub { version
(); exit 0; },
52 'extra-override'=> undef,
68 printf g_
("Debian %s version %s.\n"), $Dpkg::PROGNAME
, $Dpkg::PROGVERSION
;
73 "Usage: %s [<option>...] <binary-path> [<override-file> [<path-prefix>]] > Packages
76 -t, --type <type> scan for <type> packages (default is 'deb').
77 -a, --arch <arch> architecture to scan for.
78 -h, --hash <hash-list> only generate hashes for the specified list.
79 -m, --multiversion allow multiple versions of a single package.
80 -e, --extra-override <file>
81 use extra override file.
82 -M, --medium <medium> add X-Medium field for dselect multicd access method
83 -?, --help show this help message.
84 --version show the version.
91 my $comp_file = Dpkg
::Compression
::FileHandle
->new(filename
=> $override);
93 while (<$comp_file>) {
98 my ($p, $priority, $section, $maintainer) = split(/\s+/, $_, 4);
100 if (not defined($packages{$p})) {
101 push(@spuriousover, $p);
105 for my $package (@
{$packages{$p}}) {
107 if ($maintainer =~ m/(.+?)\s*=\>\s*(.+)/) {
110 my $debmaint = $$package{Maintainer
};
111 if (none
{ $debmaint eq $_ } split m{\s*//\s*}, $oldmaint) {
113 sprintf(g_
(' %s (package says %s, not %s)'),
114 $p, $$package{Maintainer
}, $oldmaint));
116 $$package{Maintainer
} = $newmaint;
118 } elsif ($$package{Maintainer
} eq $maintainer) {
119 push(@samemaint, " $p ($maintainer)");
121 warning
(g_
('unconditional maintainer override for %s'), $p);
122 $$package{Maintainer
} = $maintainer;
125 $$package{Priority
} = $priority;
126 $$package{Section
} = $section;
134 sub load_override_extra
136 my $extra_override = shift;
137 my $comp_file = Dpkg
::Compression
::FileHandle
->new(filename
=> $extra_override);
139 while (<$comp_file>) {
144 my ($p, $field, $value) = split(/\s+/, $_, 3);
146 next unless defined($packages{$p});
148 for my $package (@
{$packages{$p}}) {
149 $$package{$field} = $value;
157 my ($pathprefix, $fn) = @_;
159 my $fields = Dpkg
::Control
->new(type
=> CTRL_INDEX_PKG
);
161 open my $output_fh, '-|', 'dpkg-deb', '-I', $fn, 'control'
162 or syserr
(g_
('cannot fork for %s'), 'dpkg-deb');
163 $fields->parse($output_fh, $fn)
164 or error
(g_
("couldn't parse control information from %s"), $fn);
167 warning
(g_
("'dpkg-deb -I %s control' exited with %d, skipping package"),
172 my $p = $fields->{'Package'};
173 error
(g_
('no Package field in control file of %s'), $fn)
176 if (defined($packages{$p}) and not $options{multiversion
}) {
177 foreach my $pkg (@
{$packages{$p}}) {
178 if (version_compare_relation
($fields->{'Version'}, REL_GT
,
181 warning
(g_
('package %s (filename %s) is repeat but newer ' .
182 'version; used that one and ignored data from %s!'),
183 $p, $fn, $pkg->{Filename
});
186 warning
(g_
('package %s (filename %s) is repeat; ' .
187 'ignored that one and using data from %s!'),
188 $p, $fn, $pkg->{Filename
});
194 warning
(g_
('package %s (filename %s) has Filename field!'), $p, $fn)
195 if defined($fields->{'Filename'});
196 $fields->{'Filename'} = "$pathprefix$fn";
198 my $sums = Dpkg
::Checksums
->new();
199 $sums->add_from_file($fn);
200 foreach my $alg (checksums_get_list
()) {
201 next if %hash and not $hash{$alg};
204 $fields->{'MD5sum'} = $sums->get_checksum($fn, $alg);
206 $fields->{$alg} = $sums->get_checksum($fn, $alg);
209 $fields->{'Size'} = $sums->get_size($fn);
210 $fields->{'X-Medium'} = $options{medium
} if defined $options{medium
};
212 push @
{$packages{$p}}, $fields;
216 local $SIG{__WARN__
} = sub { usageerr
($_[0]) };
217 GetOptions
(\
%options, @options_spec);
220 if (not (@ARGV >= 1 and @ARGV <= 3)) {
221 usageerr
(g_
('one to three arguments expected'));
224 my $type = $options{type
} // 'deb';
225 my $arch = $options{arch
};
226 %hash = map { $_ => 1 } split /,/, $options{hash
} // '';
228 foreach my $alg (keys %hash) {
229 if (not checksums_is_supported
($alg)) {
230 usageerr
(g_
('unsupported checksum \'%s\''), $alg);
234 my ($binarypath, $override, $pathprefix) = @ARGV;
236 if (not -e
$binarypath) {
237 error
(g_
('binary path %s not found'), $binarypath);
239 if (defined $override and not -e
$override) {
240 error
(g_
('override file %s not found'), $override);
246 if ($options{arch
}) {
247 $find_filter = qr/_(?:all|${arch})\.$type$/;
249 $find_filter = qr/\.$type$/;
252 my $scan_archives = sub {
253 push @archives, $File::Find
::name
if m/$find_filter/;
256 find
({ follow
=> 1, follow_skip
=> 2, wanted
=> $scan_archives}, $binarypath);
257 foreach my $fn (@archives) {
258 process_deb
($pathprefix, $fn);
261 load_override
($override) if defined $override;
262 load_override_extra
($options{'extra-override'}) if defined $options{'extra-override'};
266 my $records_written = 0;
267 for my $p (sort keys %packages) {
268 if (defined($override) and not defined($overridden{$p})) {
269 push @missingover, $p;
271 for my $package (sort { $a->{Version
} cmp $b->{Version
} } @
{$packages{$p}}) {
272 print("$package\n") or syserr
(g_
('failed when writing stdout'));
276 close(STDOUT
) or syserr
(g_
("couldn't close stdout"));
279 warning
(g_
('Packages in override file with incorrect old maintainer value:'));
280 warning
($_) foreach (@changedmaint);
283 warning
(g_
('Packages specifying same maintainer as override file:'));
284 warning
($_) foreach (@samemaint);
287 warning
(g_
('Packages in archive but missing from override file:'));
288 warning
(' %s', join(' ', @missingover));
291 warning
(g_
('Packages in override file but not in archive:'));
292 warning
(' %s', join(' ', @spuriousover));
295 info
(g_
('Wrote %s entries to output Packages file.'), $records_written);