Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | #!/usr/bin/perl |
2 | # | |
3 | # dpkg-scanpackages | |
4 | # | |
5 | # Copyright © 2006-2015 Guillem Jover <guillem@debian.org> | |
6 | # | |
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. | |
11 | # | |
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. | |
16 | # | |
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/>. | |
19 | ||
20 | use warnings; | |
21 | use strict; | |
22 | ||
23 | use Getopt::Long qw(:config posix_default bundling no_ignorecase); | |
24 | use File::Find; | |
25 | ||
26 | use Dpkg (); | |
27 | use Dpkg::Gettext; | |
28 | use Dpkg::ErrorHandling; | |
29 | use Dpkg::Util qw(:list); | |
30 | use Dpkg::Control; | |
31 | use Dpkg::Version; | |
32 | use Dpkg::Checksums; | |
33 | use Dpkg::Compression::FileHandle; | |
34 | ||
35 | textdomain('dpkg-dev'); | |
36 | ||
37 | # Do not pollute STDOUT with info messages | |
38 | report_options(info_fh => \*STDERR); | |
39 | ||
40 | my (@samemaint, @changedmaint); | |
41 | my @spuriousover; | |
42 | my %packages; | |
43 | my %overridden; | |
44 | my %hash; | |
45 | ||
46 | my %options = (help => sub { usage(); exit 0; }, | |
47 | version => sub { version(); exit 0; }, | |
48 | type => undef, | |
49 | arch => undef, | |
50 | hash => undef, | |
51 | multiversion => 0, | |
52 | 'extra-override'=> undef, | |
53 | medium => undef, | |
54 | ); | |
55 | ||
56 | my @options_spec = ( | |
57 | 'help|?', | |
58 | 'version', | |
59 | 'type|t=s', | |
60 | 'arch|a=s', | |
61 | 'hash|h=s', | |
62 | 'multiversion|m!', | |
63 | 'extra-override|e=s', | |
64 | 'medium|M=s', | |
65 | ); | |
66 | ||
67 | sub version { | |
68 | printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION; | |
69 | } | |
70 | ||
71 | sub usage { | |
72 | printf g_( | |
73 | "Usage: %s [<option>...] <binary-path> [<override-file> [<path-prefix>]] > Packages | |
74 | ||
75 | Options: | |
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. | |
85 | "), $Dpkg::PROGNAME; | |
86 | } | |
87 | ||
88 | sub load_override | |
89 | { | |
90 | my $override = shift; | |
91 | my $comp_file = Dpkg::Compression::FileHandle->new(filename => $override); | |
92 | ||
93 | while (<$comp_file>) { | |
94 | s/\#.*//; | |
95 | s/\s+$//; | |
96 | next unless $_; | |
97 | ||
98 | my ($p, $priority, $section, $maintainer) = split(/\s+/, $_, 4); | |
99 | ||
100 | if (not defined($packages{$p})) { | |
101 | push(@spuriousover, $p); | |
102 | next; | |
103 | } | |
104 | ||
105 | for my $package (@{$packages{$p}}) { | |
106 | if ($maintainer) { | |
107 | if ($maintainer =~ m/(.+?)\s*=\>\s*(.+)/) { | |
108 | my $oldmaint = $1; | |
109 | my $newmaint = $2; | |
110 | my $debmaint = $$package{Maintainer}; | |
111 | if (none { $debmaint eq $_ } split m{\s*//\s*}, $oldmaint) { | |
112 | push(@changedmaint, | |
113 | sprintf(g_(' %s (package says %s, not %s)'), | |
114 | $p, $$package{Maintainer}, $oldmaint)); | |
115 | } else { | |
116 | $$package{Maintainer} = $newmaint; | |
117 | } | |
118 | } elsif ($$package{Maintainer} eq $maintainer) { | |
119 | push(@samemaint, " $p ($maintainer)"); | |
120 | } else { | |
121 | warning(g_('unconditional maintainer override for %s'), $p); | |
122 | $$package{Maintainer} = $maintainer; | |
123 | } | |
124 | } | |
125 | $$package{Priority} = $priority; | |
126 | $$package{Section} = $section; | |
127 | } | |
128 | $overridden{$p} = 1; | |
129 | } | |
130 | ||
131 | close($comp_file); | |
132 | } | |
133 | ||
134 | sub load_override_extra | |
135 | { | |
136 | my $extra_override = shift; | |
137 | my $comp_file = Dpkg::Compression::FileHandle->new(filename => $extra_override); | |
138 | ||
139 | while (<$comp_file>) { | |
140 | s/\#.*//; | |
141 | s/\s+$//; | |
142 | next unless $_; | |
143 | ||
144 | my ($p, $field, $value) = split(/\s+/, $_, 3); | |
145 | ||
146 | next unless defined($packages{$p}); | |
147 | ||
148 | for my $package (@{$packages{$p}}) { | |
149 | $$package{$field} = $value; | |
150 | } | |
151 | } | |
152 | ||
153 | close($comp_file); | |
154 | } | |
155 | ||
156 | sub process_deb { | |
157 | my ($pathprefix, $fn) = @_; | |
158 | ||
159 | my $fields = Dpkg::Control->new(type => CTRL_INDEX_PKG); | |
160 | ||
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); | |
165 | close $output_fh; | |
166 | if ($?) { | |
167 | warning(g_("'dpkg-deb -I %s control' exited with %d, skipping package"), | |
168 | $fn, $?); | |
169 | return; | |
170 | } | |
171 | ||
172 | my $p = $fields->{'Package'}; | |
173 | error(g_('no Package field in control file of %s'), $fn) | |
174 | if not defined $p; | |
175 | ||
176 | if (defined($packages{$p}) and not $options{multiversion}) { | |
177 | foreach my $pkg (@{$packages{$p}}) { | |
178 | if (version_compare_relation($fields->{'Version'}, REL_GT, | |
179 | $pkg->{'Version'})) | |
180 | { | |
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}); | |
184 | $packages{$p} = []; | |
185 | } else { | |
186 | warning(g_('package %s (filename %s) is repeat; ' . | |
187 | 'ignored that one and using data from %s!'), | |
188 | $p, $fn, $pkg->{Filename}); | |
189 | return; | |
190 | } | |
191 | } | |
192 | } | |
193 | ||
194 | warning(g_('package %s (filename %s) has Filename field!'), $p, $fn) | |
195 | if defined($fields->{'Filename'}); | |
196 | $fields->{'Filename'} = "$pathprefix$fn"; | |
197 | ||
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}; | |
202 | ||
203 | if ($alg eq 'md5') { | |
204 | $fields->{'MD5sum'} = $sums->get_checksum($fn, $alg); | |
205 | } else { | |
206 | $fields->{$alg} = $sums->get_checksum($fn, $alg); | |
207 | } | |
208 | } | |
209 | $fields->{'Size'} = $sums->get_size($fn); | |
210 | $fields->{'X-Medium'} = $options{medium} if defined $options{medium}; | |
211 | ||
212 | push @{$packages{$p}}, $fields; | |
213 | } | |
214 | ||
215 | { | |
216 | local $SIG{__WARN__} = sub { usageerr($_[0]) }; | |
217 | GetOptions(\%options, @options_spec); | |
218 | } | |
219 | ||
220 | if (not (@ARGV >= 1 and @ARGV <= 3)) { | |
221 | usageerr(g_('one to three arguments expected')); | |
222 | } | |
223 | ||
224 | my $type = $options{type} // 'deb'; | |
225 | my $arch = $options{arch}; | |
226 | %hash = map { $_ => 1 } split /,/, $options{hash} // ''; | |
227 | ||
228 | foreach my $alg (keys %hash) { | |
229 | if (not checksums_is_supported($alg)) { | |
230 | usageerr(g_('unsupported checksum \'%s\''), $alg); | |
231 | } | |
232 | } | |
233 | ||
234 | my ($binarypath, $override, $pathprefix) = @ARGV; | |
235 | ||
236 | if (not -e $binarypath) { | |
237 | error(g_('binary path %s not found'), $binarypath); | |
238 | } | |
239 | if (defined $override and not -e $override) { | |
240 | error(g_('override file %s not found'), $override); | |
241 | } | |
242 | ||
243 | $pathprefix //= ''; | |
244 | ||
245 | my $find_filter; | |
246 | if ($options{arch}) { | |
247 | $find_filter = qr/_(?:all|${arch})\.$type$/; | |
248 | } else { | |
249 | $find_filter = qr/\.$type$/; | |
250 | } | |
251 | my @archives; | |
252 | my $scan_archives = sub { | |
253 | push @archives, $File::Find::name if m/$find_filter/; | |
254 | }; | |
255 | ||
256 | find({ follow => 1, follow_skip => 2, wanted => $scan_archives}, $binarypath); | |
257 | foreach my $fn (@archives) { | |
258 | process_deb($pathprefix, $fn); | |
259 | } | |
260 | ||
261 | load_override($override) if defined $override; | |
262 | load_override_extra($options{'extra-override'}) if defined $options{'extra-override'}; | |
263 | ||
264 | my @missingover=(); | |
265 | ||
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; | |
270 | } | |
271 | for my $package (sort { $a->{Version} cmp $b->{Version} } @{$packages{$p}}) { | |
272 | print("$package\n") or syserr(g_('failed when writing stdout')); | |
273 | $records_written++; | |
274 | } | |
275 | } | |
276 | close(STDOUT) or syserr(g_("couldn't close stdout")); | |
277 | ||
278 | if (@changedmaint) { | |
279 | warning(g_('Packages in override file with incorrect old maintainer value:')); | |
280 | warning($_) foreach (@changedmaint); | |
281 | } | |
282 | if (@samemaint) { | |
283 | warning(g_('Packages specifying same maintainer as override file:')); | |
284 | warning($_) foreach (@samemaint); | |
285 | } | |
286 | if (@missingover) { | |
287 | warning(g_('Packages in archive but missing from override file:')); | |
288 | warning(' %s', join(' ', @missingover)); | |
289 | } | |
290 | if (@spuriousover) { | |
291 | warning(g_('Packages in override file but not in archive:')); | |
292 | warning(' %s', join(' ', @spuriousover)); | |
293 | } | |
294 | ||
295 | info(g_('Wrote %s entries to output Packages file.'), $records_written); |