… | |
… | |
142 | |
142 | |
143 | ############### |
143 | ############### |
144 | # OUTPUT DATA # |
144 | # OUTPUT DATA # |
145 | ############### |
145 | ############### |
146 | |
146 | |
147 | sub print_orphans |
147 | # Go through the list of all packages and call a subroutine on each installed |
148 | { |
148 | # package. |
149 | foreach my $package_data (values %installed_packages) { |
149 | # Parameter 1: $sub: Reference to the subroutine to call |
150 | foreach my $entry (@$package_data) { |
150 | # Each call gets two parameters: the entry and $long |
151 | if ($entry->{status} eq 'install ok installed') { |
151 | # Parameter 2..: @params: All other parameters |
152 | if (! @{$entry->{lists}}) { |
152 | # Returns: Nothing |
153 | print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n"; |
153 | # Side effects: Generates output on STDOUT |
154 | } |
154 | sub iterate_through_packages { |
155 | } |
155 | my ($sub, @params) = @_; |
156 | } |
|
|
157 | } |
|
|
158 | } |
|
|
159 | |
|
|
160 | sub print_all |
|
|
161 | { |
|
|
162 | foreach my $package_name (sort keys %installed_packages) { |
156 | foreach my $package_name (sort keys %installed_packages) { |
163 | foreach my $entry (@{$installed_packages{$package_name}}) { |
157 | foreach my $entry (@{$installed_packages{$package_name}}) { |
164 | if ($entry->{status} eq 'install ok installed') { |
158 | if ($entry->{status} eq 'install ok installed') { |
165 | print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n"; |
159 | &$sub($entry, @params) |
166 | } |
160 | } |
167 | } |
161 | } |
168 | } |
162 | } |
169 | } |
163 | } |
170 | |
164 | |
|
|
165 | # Print an entry, either with or without its archives |
|
|
166 | # Parameter 1: $entry: a hash reference containing keys package, architecture |
|
|
167 | # and version (as well as lists if $long is true) |
|
|
168 | # Parameter 2: $long: whether to print the archives too |
|
|
169 | # Returns: nothing |
|
|
170 | # Side effects: Generates output on STDOUT |
|
|
171 | sub print_item |
|
|
172 | { |
|
|
173 | my ($entry, $long) = @_; |
|
|
174 | if ($long) { |
|
|
175 | print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n"; |
|
|
176 | } else { |
|
|
177 | print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n"; |
|
|
178 | } |
|
|
179 | } |
|
|
180 | |
|
|
181 | # Print all packages, including archives |
|
|
182 | sub print_all |
|
|
183 | { |
|
|
184 | iterate_through_packages(\&print_item, 1); |
|
|
185 | } |
|
|
186 | |
|
|
187 | |
|
|
188 | # Print only those packages that have no archive associated with them |
|
|
189 | sub print_orphans |
|
|
190 | { |
|
|
191 | iterate_through_packages(\&print_orphans_item); |
|
|
192 | } |
|
|
193 | |
|
|
194 | # Callback: check whether an entry is an orphan and if so print it |
|
|
195 | sub print_orphans_item |
|
|
196 | { |
|
|
197 | my ($entry) = @_; |
|
|
198 | if (! @{$entry->{lists}}) { |
|
|
199 | print_item($entry, 0); |
|
|
200 | } |
|
|
201 | } |
|
|
202 | |
|
|
203 | # Print those packages which are only in the specified archives |
171 | sub print_archives_only |
204 | sub print_archives_only |
172 | { |
205 | { |
173 | my ($archives,$long) = @_; |
206 | my ($archives,$long) = @_; |
174 | my %archives; |
207 | my %archives; |
175 | foreach my $archive (split (/,/,$archives)) { |
208 | foreach my $archive (split (/,/,$archives)) { |
176 | $archives{$archive} = 1; |
209 | $archives{$archive} = 1; |
177 | } |
210 | } |
178 | foreach my $package_name (sort keys %installed_packages) { |
211 | iterate_through_packages(\&print_archives_only_item, \%archives, $long); |
179 | foreach my $entry (@{$installed_packages{$package_name}}) { |
212 | } |
180 | if ($entry->{status} eq 'install ok installed') { |
213 | |
|
|
214 | # Callback: print an entry if it is only in the specified archives |
|
|
215 | sub print_archives_only_item |
|
|
216 | { |
|
|
217 | my ($entry,$archives, $long) = @_; |
181 | my $valid = 1; |
218 | my $valid = 1; |
182 | my $nr=0; |
|
|
183 | foreach my $list (@{$entry->{lists}}) { |
219 | foreach my $list (@{$entry->{lists}}) { |
184 | $nr++; |
|
|
185 | if (! exists($archives{$list})) { |
220 | if (! exists($archives->{$list})) { |
186 | $valid = 0; |
221 | $valid = 0; |
187 | last; |
222 | last; |
188 | } |
|
|
189 | } |
|
|
190 | if ($valid and $nr) { |
|
|
191 | if ($long) { |
|
|
192 | print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n"; |
|
|
193 | } else { |
|
|
194 | print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n"; |
|
|
195 | } |
|
|
196 | } |
|
|
197 | } |
223 | } |
198 | } |
224 | } |
|
|
225 | if ($valid and @{$entry->{lists}}) { |
|
|
226 | print_item($entry, $long) |
199 | } |
227 | } |
200 | } |
228 | } |
201 | |
229 | |
|
|
230 | # Print those packages which are only in the archives specified through a |
|
|
231 | # regular expression |
202 | sub print_archives_only_regexp |
232 | sub print_archives_only_regexp |
203 | { |
233 | { |
204 | my ($archives_regexp,$long) = @_; |
234 | my ($archives_regexp,$long) = @_; |
205 | foreach my $package_name (sort keys %installed_packages) { |
235 | iterate_through_packages(\&print_archives_only_regexp_item, $archives_regexp, $long); |
206 | foreach my $entry (@{$installed_packages{$package_name}}) { |
236 | } |
207 | if ($entry->{status} eq 'install ok installed') { |
237 | |
|
|
238 | # Callback: print an entry if it is only in the archives specified through a |
|
|
239 | # regular expression |
|
|
240 | sub print_archives_only_regexp_item |
|
|
241 | { |
|
|
242 | my ($entry, $archives_regexp, $long) = @_; |
208 | my $valid = 1; |
243 | my $valid = 1; |
209 | my $nr=0; |
|
|
210 | foreach my $list (@{$entry->{lists}}) { |
244 | foreach my $list (@{$entry->{lists}}) { |
211 | $nr++; |
|
|
212 | if (! ($list =~ /$archives_regexp/)) { |
245 | if (! ($list =~ /$archives_regexp/)) { |
213 | $valid = 0; |
246 | $valid = 0; |
214 | last; |
247 | last; |
215 | } |
|
|
216 | } |
|
|
217 | if ($valid and $nr) { |
|
|
218 | if ($long) { |
|
|
219 | print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n"; |
|
|
220 | } else { |
|
|
221 | print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n"; |
|
|
222 | } |
|
|
223 | } |
|
|
224 | } |
248 | } |
225 | } |
249 | } |
|
|
250 | if ($valid and @{$entry->{lists}}) { |
|
|
251 | print_item($entry, $long) |
|
|
252 | } |
|
|
253 | } |
|
|
254 | |
|
|
255 | # Print those packages which are not in the specified archives |
|
|
256 | sub print_archives_except |
|
|
257 | { |
|
|
258 | my ($archives,$long) = @_; |
|
|
259 | my %archives; |
|
|
260 | foreach my $archive (split (/,/,$archives)) { |
|
|
261 | $archives{$archive} = 1; |
|
|
262 | } |
|
|
263 | iterate_through_packages(\&print_archives_except_item, \%archives, $long); |
|
|
264 | } |
|
|
265 | |
|
|
266 | # Callback: print an entry if it is not in the specified archives |
|
|
267 | sub print_archives_except_item |
|
|
268 | { |
|
|
269 | my ($entry,$archives, $long) = @_; |
|
|
270 | my $valid = 1; |
|
|
271 | foreach my $list (@{$entry->{lists}}) { |
|
|
272 | if (exists($archives->{$list})) { |
|
|
273 | $valid = 0; |
|
|
274 | last; |
226 | } |
275 | } |
|
|
276 | } |
|
|
277 | if ($valid and @{$entry->{lists}}) { |
|
|
278 | print_item($entry, $long) |
|
|
279 | } |
227 | } |
280 | } |
228 | |
281 | |
|
|
282 | # Print those packages which are not in the archives specified through a |
|
|
283 | # regular expression |
|
|
284 | sub print_archives_except_regexp |
|
|
285 | { |
|
|
286 | my ($archives_regexp,$long) = @_; |
|
|
287 | iterate_through_packages(\&print_archives_except_regexp_item, $archives_regexp, $long); |
|
|
288 | } |
|
|
289 | |
|
|
290 | # Callback: print an entry if it is not in the archives specified through a |
|
|
291 | # regular expression |
|
|
292 | sub print_archives_except_regexp_item |
|
|
293 | { |
|
|
294 | my ($entry, $archives_regexp, $long) = @_; |
|
|
295 | my $valid = 1; |
|
|
296 | foreach my $list (@{$entry->{lists}}) { |
|
|
297 | if ($list =~ /$archives_regexp/) { |
|
|
298 | $valid = 0; |
|
|
299 | last; |
|
|
300 | } |
|
|
301 | } |
|
|
302 | if ($valid and @{$entry->{lists}}) { |
|
|
303 | print_item($entry, $long) |
|
|
304 | } |
|
|
305 | } |
229 | |
306 | |
230 | ######################### |
307 | ######################### |
231 | # COMMAND LINE HANDLING # |
308 | # COMMAND LINE HANDLING # |
232 | ######################### |
309 | ######################### |
233 | |
310 | |
… | |
… | |
239 | print STDERR " -o: orphans: packages that are not in any archive\n"; |
316 | print STDERR " -o: orphans: packages that are not in any archive\n"; |
240 | print STDERR " -a ARCHS: archives: list all packages that are only in one of the listed\n"; |
317 | print STDERR " -a ARCHS: archives: list all packages that are only in one of the listed\n"; |
241 | print STDERR " archives (seperated by commas)\n"; |
318 | print STDERR " archives (seperated by commas)\n"; |
242 | print STDERR " -A ARCHREGEXP: archives: list all packages that are only in archives\n"; |
319 | print STDERR " -A ARCHREGEXP: archives: list all packages that are only in archives\n"; |
243 | print STDERR " that match the regular expression\n"; |
320 | print STDERR " that match the regular expression\n"; |
|
|
321 | print STDERR " -x ARCHS: except: list all packages that are not in one of the listed\n"; |
|
|
322 | print STDERR " archives (seperated by commas)\n"; |
|
|
323 | print STDERR " -X ARCHREGEXP: except: list all packages that are not in archives\n"; |
|
|
324 | print STDERR " that match the regular expression\n"; |
244 | print STDERR " -l: long: print archives too\n"; |
325 | print STDERR " -l: long: print archives too\n"; |
245 | |
326 | |
246 | print STDERR "Default: print all packages and sources\n"; |
327 | print STDERR "Default: print all packages and sources\n"; |
247 | } |
328 | } |
248 | |
329 | |
… | |
… | |
259 | |
340 | |
260 | $Getopt::Std::STANDARD_HELP_VERSION=1; |
341 | $Getopt::Std::STANDARD_HELP_VERSION=1; |
261 | |
342 | |
262 | our $VERSION=$version; |
343 | our $VERSION=$version; |
263 | my %options; |
344 | my %options; |
264 | if (! getopts('hVola:A:',\%options)) |
345 | if (! getopts('hVola:A:x:X:',\%options)) |
265 | { |
346 | { |
266 | print_help(); |
347 | print_help(); |
267 | exit 1; |
348 | exit 1; |
268 | } |
349 | } |
269 | my $long=0; |
350 | my $long=0; |
… | |
… | |
289 | } |
370 | } |
290 | if ($options{A}) { |
371 | if ($options{A}) { |
291 | print_archives_only_regexp($options{A},$long); |
372 | print_archives_only_regexp($options{A},$long); |
292 | exit 0; |
373 | exit 0; |
293 | } |
374 | } |
|
|
375 | if ($options{x}) { |
|
|
376 | print_archives_except($options{x},$long); |
|
|
377 | exit 0; |
|
|
378 | } |
|
|
379 | if ($options{X}) { |
|
|
380 | print_archives_except_regexp($options{X},$long); |
|
|
381 | exit 0; |
|
|
382 | } |
294 | print_all; |
383 | print_all; |
295 | |
384 | |
296 | |
385 | |
297 | # vim:sw=2:ft=perl:expandtab: |
386 | # vim:sw=2:ft=perl:expandtab: |