Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | #!/usr/bin/perl |
2 | # | |
3 | # Copyright © 1999 Roderick Schertler | |
4 | # Copyright © 2002 Wichert Akkerman <wakkerma@debian.org> | |
5 | # Copyright © 2006-2009, 2011-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 (at | |
10 | # 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 strict; | |
21 | use warnings; | |
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::Checksums; | |
32 | use Dpkg::Compression::FileHandle; | |
33 | use Dpkg::Compression; | |
34 | ||
35 | textdomain('dpkg-dev'); | |
36 | ||
37 | # Hash of lists. The constants below describe what is in the lists. | |
38 | my %override; | |
39 | use constant { | |
40 | O_PRIORITY => 0, | |
41 | O_SECTION => 1, | |
42 | O_MAINT_FROM => 2, # undef for non-specific, else listref | |
43 | O_MAINT_TO => 3, # undef if there's no maint override | |
44 | }; | |
45 | ||
46 | my %extra_override; | |
47 | ||
48 | my %priority = ( | |
49 | 'extra' => 1, | |
50 | 'optional' => 2, | |
51 | 'standard' => 3, | |
52 | 'important' => 4, | |
53 | 'required' => 5, | |
54 | ); | |
55 | ||
56 | # Switches | |
57 | ||
58 | my $debug = 0; | |
59 | my $no_sort = 0; | |
60 | my $src_override = undef; | |
61 | my $extra_override_file = undef; | |
62 | my @sources; | |
63 | ||
64 | my @option_spec = ( | |
65 | 'debug!' => \$debug, | |
66 | 'help|?' => sub { usage(); exit 0; }, | |
67 | 'version' => sub { version(); exit 0; }, | |
68 | 'no-sort|n' => \$no_sort, | |
69 | 'source-override|s=s' => \$src_override, | |
70 | 'extra-override|e=s' => \$extra_override_file, | |
71 | ); | |
72 | ||
73 | sub version { | |
74 | printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION; | |
75 | } | |
76 | ||
77 | sub usage { | |
78 | printf g_( | |
79 | "Usage: %s [<option>...] <binary-path> [<override-file> [<path-prefix>]] > Sources | |
80 | ||
81 | Options: | |
82 | -n, --no-sort don't sort by package before outputting. | |
83 | -e, --extra-override <file> | |
84 | use extra override file. | |
85 | -s, --source-override <file> | |
86 | use file for additional source overrides, default | |
87 | is regular override file with .src appended. | |
88 | --debug turn debugging on. | |
89 | -?, --help show this help message. | |
90 | --version show the version. | |
91 | ||
92 | See the man page for the full documentation. | |
93 | "), $Dpkg::PROGNAME; | |
94 | } | |
95 | ||
96 | sub load_override { | |
97 | my $file = shift; | |
98 | local $_; | |
99 | ||
100 | my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file); | |
101 | while (<$comp_file>) { | |
102 | s/#.*//; | |
103 | next if /^\s*$/; | |
104 | s/\s+$//; | |
105 | ||
106 | my @data = split ' ', $_, 4; | |
107 | unless (@data == 3 || @data == 4) { | |
108 | warning(g_('invalid override entry at line %d (%d fields)'), | |
109 | $., 0 + @data); | |
110 | next; | |
111 | } | |
112 | my ($package, $priority, $section, $maintainer) = @data; | |
113 | if (exists $override{$package}) { | |
114 | warning(g_('ignoring duplicate override entry for %s at line %d'), | |
115 | $package, $.); | |
116 | next; | |
117 | } | |
118 | if (!$priority{$priority}) { | |
119 | warning(g_('ignoring override entry for %s, invalid priority %s'), | |
120 | $package, $priority); | |
121 | next; | |
122 | } | |
123 | ||
124 | $override{$package} = []; | |
125 | $override{$package}[O_PRIORITY] = $priority; | |
126 | $override{$package}[O_SECTION] = $section; | |
127 | if (!defined $maintainer) { | |
128 | # do nothing | |
129 | } | |
130 | elsif ($maintainer =~ /^(.*\S)\s*=>\s*(.*)$/) { | |
131 | $override{$package}[O_MAINT_FROM] = [split m{\s*//\s*}, $1]; | |
132 | $override{$package}[O_MAINT_TO] = $2; | |
133 | } | |
134 | else { | |
135 | $override{$package}[O_MAINT_TO] = $maintainer; | |
136 | } | |
137 | } | |
138 | close($comp_file); | |
139 | } | |
140 | ||
141 | sub load_src_override { | |
142 | my ($user_file, $regular_file) = @_; | |
143 | my ($file); | |
144 | local $_; | |
145 | ||
146 | if (defined $user_file) { | |
147 | $file = $user_file; | |
148 | } | |
149 | elsif (defined $regular_file) { | |
150 | my $comp = compression_guess_from_filename($regular_file); | |
151 | if (defined($comp)) { | |
152 | $file = $regular_file; | |
153 | my $ext = compression_get_property($comp, 'file_ext'); | |
154 | $file =~ s/\.$ext$/.src.$ext/; | |
155 | } else { | |
156 | $file = "$regular_file.src"; | |
157 | } | |
158 | return unless -e $file; | |
159 | } | |
160 | else { | |
161 | return; | |
162 | } | |
163 | ||
164 | debug(1, "source override file $file"); | |
165 | my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file); | |
166 | while (<$comp_file>) { | |
167 | s/#.*//; | |
168 | next if /^\s*$/; | |
169 | s/\s+$//; | |
170 | ||
171 | my @data = split ' '; | |
172 | unless (@data == 2) { | |
173 | warning(g_('invalid source override entry at line %d (%d fields)'), | |
174 | $., 0 + @data); | |
175 | next; | |
176 | } | |
177 | ||
178 | my ($package, $section) = @data; | |
179 | my $key = "source/$package"; | |
180 | if (exists $override{$key}) { | |
181 | warning(g_('ignoring duplicate source override entry for %s at line %d'), | |
182 | $package, $.); | |
183 | next; | |
184 | } | |
185 | $override{$key} = []; | |
186 | $override{$key}[O_SECTION] = $section; | |
187 | } | |
188 | close($comp_file); | |
189 | } | |
190 | ||
191 | sub load_override_extra | |
192 | { | |
193 | my $extra_override = shift; | |
194 | my $comp_file = Dpkg::Compression::FileHandle->new(filename => $extra_override); | |
195 | ||
196 | while (<$comp_file>) { | |
197 | s/\#.*//; | |
198 | s/\s+$//; | |
199 | next unless $_; | |
200 | ||
201 | my ($p, $field, $value) = split(/\s+/, $_, 3); | |
202 | $extra_override{$p}{$field} = $value; | |
203 | } | |
204 | close($comp_file); | |
205 | } | |
206 | ||
207 | # Given PREFIX and DSC-FILE, process the file and returns the fields. | |
208 | ||
209 | sub process_dsc { | |
210 | my ($prefix, $file) = @_; | |
211 | ||
212 | my $basename = $file; | |
213 | my $dir = ($basename =~ s{^(.*)/}{}) ? $1 : ''; | |
214 | $dir = "$prefix$dir"; | |
215 | $dir =~ s{/+$}{}; | |
216 | $dir = '.' if $dir eq ''; | |
217 | ||
218 | # Parse ‘.dsc’ file. | |
219 | my $fields = Dpkg::Control->new(type => CTRL_PKG_SRC); | |
220 | $fields->load($file); | |
221 | $fields->set_options(type => CTRL_INDEX_SRC); | |
222 | ||
223 | # Get checksums | |
224 | my $checksums = Dpkg::Checksums->new(); | |
225 | $checksums->add_from_file($file, key => $basename); | |
226 | $checksums->add_from_control($fields, use_files_for_md5 => 1); | |
227 | ||
228 | my $source = $fields->{Source}; | |
229 | my @binary = split /\s*,\s*/, $fields->{Binary} // ''; | |
230 | ||
231 | error(g_('no binary packages specified in %s'), $file) unless (@binary); | |
232 | ||
233 | # Rename the source field to package. | |
234 | $fields->{Package} = $fields->{Source}; | |
235 | delete $fields->{Source}; | |
236 | ||
237 | # The priority for the source package is the highest priority of the | |
238 | # binary packages it produces. | |
239 | my @binary_by_priority = sort { | |
240 | ($override{$a} ? $priority{$override{$a}[O_PRIORITY]} : 0) | |
241 | <=> | |
242 | ($override{$b} ? $priority{$override{$b}[O_PRIORITY]} : 0) | |
243 | } @binary; | |
244 | my $priority_override = $override{$binary_by_priority[-1]}; | |
245 | my $priority = $priority_override | |
246 | ? $priority_override->[O_PRIORITY] | |
247 | : undef; | |
248 | $fields->{Priority} = $priority if defined $priority; | |
249 | ||
250 | # For the section override, first check for a record from the source | |
251 | # override file, else use the regular override file. | |
252 | my $section_override = $override{"source/$source"} || $override{$source}; | |
253 | my $section = $section_override | |
254 | ? $section_override->[O_SECTION] | |
255 | : undef; | |
256 | $fields->{Section} = $section if defined $section; | |
257 | ||
258 | # For the maintainer override, use the override record for the first | |
259 | # binary. Modify the maintainer if necessary. | |
260 | my $maintainer_override = $override{$binary[0]}; | |
261 | if ($maintainer_override && defined $maintainer_override->[O_MAINT_TO]) { | |
262 | if (!defined $maintainer_override->[O_MAINT_FROM] || | |
263 | any { $fields->{Maintainer} eq $_ } | |
264 | @{ $maintainer_override->[O_MAINT_FROM] }) { | |
265 | $fields->{Maintainer} = $maintainer_override->[O_MAINT_TO]; | |
266 | } | |
267 | } | |
268 | ||
269 | # Process extra override | |
270 | if (exists $extra_override{$source}) { | |
271 | my ($field, $value); | |
272 | while (($field, $value) = each %{$extra_override{$source}}) { | |
273 | $fields->{$field} = $value; | |
274 | } | |
275 | } | |
276 | ||
277 | # A directory field will be inserted just before the files field. | |
278 | $fields->{Directory} = $dir; | |
279 | ||
280 | $checksums->export_to_control($fields, use_files_for_md5 => 1); | |
281 | ||
282 | push @sources, $fields; | |
283 | } | |
284 | ||
285 | ### Main | |
286 | ||
287 | { | |
288 | local $SIG{__WARN__} = sub { usageerr($_[0]) }; | |
289 | GetOptions(@option_spec); | |
290 | } | |
291 | ||
292 | usageerr(g_('one to three arguments expected')) | |
293 | if @ARGV < 1 or @ARGV > 3; | |
294 | ||
295 | push @ARGV, undef if @ARGV < 2; | |
296 | push @ARGV, '' if @ARGV < 3; | |
297 | my ($dir, $override, $prefix) = @ARGV; | |
298 | ||
299 | report_options(debug_level => $debug); | |
300 | ||
301 | load_override $override if defined $override; | |
302 | load_src_override $src_override, $override; | |
303 | load_override_extra $extra_override_file if defined $extra_override_file; | |
304 | ||
305 | my @dsc; | |
306 | my $scan_dsc = sub { | |
307 | push @dsc, $File::Find::name if m/\.dsc$/; | |
308 | }; | |
309 | ||
310 | find({ follow => 1, follow_skip => 2, wanted => $scan_dsc }, $dir); | |
311 | foreach my $fn (@dsc) { | |
312 | # FIXME: Fix it instead to not die on syntax and general errors? | |
313 | eval { | |
314 | process_dsc($prefix, $fn); | |
315 | }; | |
316 | if ($@) { | |
317 | warn $@; | |
318 | next; | |
319 | } | |
320 | } | |
321 | ||
322 | if (not $no_sort) { | |
323 | @sources = sort { | |
324 | $a->{Package} . $a->{Version} cmp $b->{Package} . $b->{Version} | |
325 | } @sources; | |
326 | } | |
327 | foreach my $dsc (@sources) { | |
328 | $dsc->output(\*STDOUT); | |
329 | print "\n"; | |
330 | } |