… | |
… | |
22 | |
22 | |
23 | use strict; |
23 | use strict; |
24 | use Getopt::Std; |
24 | use Getopt::Std; |
25 | |
25 | |
26 | my $execname = 'apt-installed-status'; |
26 | my $execname = 'apt-installed-status'; |
27 | my $version = '1.0'; |
27 | my $version = '1.1'; |
28 | |
28 | |
29 | |
29 | |
30 | ########################## |
30 | ########################## |
31 | # HANDLE DATA COLLECTION # |
31 | # HANDLE DATA COLLECTION # |
32 | ########################## |
32 | ########################## |
… | |
… | |
51 | # 'package': string: package name (same as the primary hash key) |
51 | # 'package': string: package name (same as the primary hash key) |
52 | # 'architecture': string: architecture |
52 | # 'architecture': string: architecture |
53 | # 'version': string: version |
53 | # 'version': string: version |
54 | # 'multiarch': string: package multi-arch option (not always available) |
54 | # 'multiarch': string: package multi-arch option (not always available) |
55 | my %package_lists; |
55 | my %package_lists; |
|
|
56 | |
|
|
57 | # When only the names of the package lists is asked for, we fill this variable. |
|
|
58 | # archives: array |
|
|
59 | # counter: string: name of the archive |
|
|
60 | my @archive_names; |
56 | |
61 | |
57 | |
62 | |
58 | # Read a package list file and save it into global variable %package_lists. |
63 | # Read a package list file and save it into global variable %package_lists. |
59 | # Parameter 1: $file: File name (within /var/lib/apt/lists) of the package list |
64 | # Parameter 1: $file: File name (within /var/lib/apt/lists) of the package list |
60 | # Returns: Nothing |
65 | # Returns: Nothing |
… | |
… | |
155 | read_installed_packages(); |
160 | read_installed_packages(); |
156 | read_all_package_lists(); |
161 | read_all_package_lists(); |
157 | find_all_packages(); |
162 | find_all_packages(); |
158 | } |
163 | } |
159 | |
164 | |
|
|
165 | # Determine which package archives are available. |
|
|
166 | # Parameters: None |
|
|
167 | # Returns: Nothing |
|
|
168 | # Side effects: Fills in global variabale @archive_names |
|
|
169 | sub init_names |
|
|
170 | { |
|
|
171 | opendir(DIR, '/var/lib/apt/lists') or die "Can't opendir: $!"; |
|
|
172 | while (defined(my $file = readdir(DIR))) { |
|
|
173 | push (@archive_names,$file) if $file =~ /_Packages$/ |
|
|
174 | } |
|
|
175 | closedir(DIR); |
|
|
176 | } |
|
|
177 | |
160 | |
178 | |
161 | ############### |
179 | ############### |
162 | # OUTPUT DATA # |
180 | # OUTPUT DATA # |
163 | ############### |
181 | ############### |
|
|
182 | |
|
|
183 | sub print_archive_names |
|
|
184 | { |
|
|
185 | print join("\n", sort @archive_names)."\n"; |
|
|
186 | } |
|
|
187 | |
|
|
188 | sub print_archive_names_only |
|
|
189 | { |
|
|
190 | my ($archives) = @_; |
|
|
191 | my %archives; |
|
|
192 | foreach my $archive (split (/,/,$archives)) { |
|
|
193 | $archives{$archive} = 1; |
|
|
194 | } |
|
|
195 | print join("\n", sort (grep { exists $archives{$_} } @archive_names))."\n"; |
|
|
196 | } |
|
|
197 | |
|
|
198 | sub print_archive_names_only_regexp |
|
|
199 | { |
|
|
200 | my ($archives_regexp) = @_; |
|
|
201 | print join("\n", sort (grep /$archives_regexp/,@archive_names))."\n"; |
|
|
202 | } |
|
|
203 | |
|
|
204 | sub print_archive_names_except |
|
|
205 | { |
|
|
206 | my ($archives) = @_; |
|
|
207 | my %archives; |
|
|
208 | foreach my $archive (split (/,/,$archives)) { |
|
|
209 | $archives{$archive} = 1; |
|
|
210 | } |
|
|
211 | print join("\n", sort (grep { ! exists $archives{$_} } @archive_names))."\n"; |
|
|
212 | } |
|
|
213 | |
|
|
214 | sub print_archive_names_except_regexp |
|
|
215 | { |
|
|
216 | my ($archives_regexp) = @_; |
|
|
217 | print join("\n", sort (grep !/$archives_regexp/,@archive_names))."\n"; |
|
|
218 | } |
164 | |
219 | |
165 | # Go through the list of all packages and call a subroutine on each installed |
220 | # Go through the list of all packages and call a subroutine on each installed |
166 | # package. |
221 | # package. |
167 | # Parameter 1: $sub: Reference to the subroutine to call |
222 | # Parameter 1: $sub: Reference to the subroutine to call |
168 | # Each call gets two parameters: the entry and $long |
223 | # Each call gets two parameters: the entry and $long |
… | |
… | |
339 | print STDERR " -x ARCHS: except: list all packages that are not in one of the listed\n"; |
394 | print STDERR " -x ARCHS: except: list all packages that are not in one of the listed\n"; |
340 | print STDERR " archives (seperated by commas)\n"; |
395 | print STDERR " archives (seperated by commas)\n"; |
341 | print STDERR " -X ARCHREGEXP: except: list all packages that are not in archives\n"; |
396 | print STDERR " -X ARCHREGEXP: except: list all packages that are not in archives\n"; |
342 | print STDERR " that match the regular expression\n"; |
397 | print STDERR " that match the regular expression\n"; |
343 | print STDERR " -l: long: print archives too\n"; |
398 | print STDERR " -l: long: print archives too\n"; |
|
|
399 | print STDERR " -L: list: print archives that are selected instead of packages\n"; |
344 | |
400 | |
345 | print STDERR "Default: print all packages and sources\n"; |
401 | print STDERR "Default: print all packages and sources\n"; |
346 | } |
402 | } |
347 | |
403 | |
348 | sub print_version |
404 | sub print_version |
… | |
… | |
358 | |
414 | |
359 | $Getopt::Std::STANDARD_HELP_VERSION=1; |
415 | $Getopt::Std::STANDARD_HELP_VERSION=1; |
360 | |
416 | |
361 | our $VERSION=$version; |
417 | our $VERSION=$version; |
362 | my %options; |
418 | my %options; |
363 | if (! getopts('hVola:A:x:X:',\%options)) |
419 | if (! getopts('hVoLla:A:x:X:',\%options)) |
364 | { |
420 | { |
365 | print_help(); |
421 | print_help(); |
366 | exit 1; |
422 | exit 1; |
367 | } |
423 | } |
368 | my $long=0; |
424 | my $long=0; |
|
|
425 | my $names_only=0; |
|
|
426 | |
369 | if ($options{'h'}) { |
427 | if ($options{'h'}) { |
370 | print_help(); |
428 | print_help(); |
371 | exit 0; |
429 | exit 0; |
372 | } |
430 | } |
373 | if ($options{'V'}) { |
431 | if ($options{'V'}) { |
374 | print_version(); |
432 | print_version(); |
375 | exit 0; |
433 | exit 0; |
376 | } |
434 | } |
|
|
435 | if ($options{'L'}) { |
|
|
436 | $names_only=1; |
|
|
437 | } |
|
|
438 | if ($names_only) { |
|
|
439 | init_names(); |
|
|
440 | } else { |
377 | init(); |
441 | init(); |
|
|
442 | } |
378 | if ($options{'o'}) { |
443 | if ($options{'o'}) { |
379 | print_orphans(); |
444 | print_orphans(); |
380 | exit 0; |
445 | exit 0; |
381 | } |
446 | } |
382 | if ($options{l}) { |
447 | if ($options{l}) { |
383 | $long = 1; |
448 | $long = 1; |
384 | } |
449 | } |
385 | if ($options{a}) { |
450 | if ($options{a}) { |
|
|
451 | if ($names_only) { |
|
|
452 | print_archive_names_only($options{a}); |
|
|
453 | } else { |
386 | print_archives_only($options{a},$long); |
454 | print_archives_only($options{a},$long); |
|
|
455 | } |
387 | exit 0; |
456 | exit 0; |
388 | } |
457 | } |
389 | if ($options{A}) { |
458 | if ($options{A}) { |
|
|
459 | if ($names_only) { |
|
|
460 | print_archive_names_only_regexp($options{A}); |
|
|
461 | } else { |
390 | print_archives_only_regexp($options{A},$long); |
462 | print_archives_only_regexp($options{A},$long); |
|
|
463 | } |
391 | exit 0; |
464 | exit 0; |
392 | } |
465 | } |
393 | if ($options{x}) { |
466 | if ($options{x}) { |
|
|
467 | if ($names_only) { |
|
|
468 | print_archive_names_except($options{x}); |
|
|
469 | } else { |
394 | print_archives_except($options{x},$long); |
470 | print_archives_except($options{x},$long); |
|
|
471 | } |
395 | exit 0; |
472 | exit 0; |
396 | } |
473 | } |
397 | if ($options{X}) { |
474 | if ($options{X}) { |
|
|
475 | if ($names_only) { |
|
|
476 | print_archive_names_except($options{X}); |
|
|
477 | } else { |
398 | print_archives_except_regexp($options{X},$long); |
478 | print_archives_except_regexp($options{X},$long); |
|
|
479 | } |
399 | exit 0; |
480 | exit 0; |
400 | } |
481 | } |
|
|
482 | if ($names_only) { |
|
|
483 | print_archive_names() |
|
|
484 | } else { |
401 | print_all; |
485 | print_all(); |
|
|
486 | } |
402 | |
487 | |
403 | |
488 | |
404 | # vim:sw=2:ft=perl:expandtab: |
489 | # vim:sw=2:ft=perl:expandtab: |