/[public]/apt-installed-status/trunk/apt-installed-status
ViewVC logotype

Contents of /apt-installed-status/trunk/apt-installed-status

Parent Directory Parent Directory | Revision Log Revision Log


Revision 337 - (show annotations)
Fri Jul 4 15:50:28 2014 UTC (10 years, 4 months ago) by frodo
File size: 13436 byte(s)
(Frodo) Add the -L option; bump version to 1.1

1 #!/usr/bin/perl -w
2
3 # Copyright (c) 2014 by Frodo Looijaard <frodo@frodo.looijaard.name>
4 #
5 # License: GPL-3.0+
6 # This program is free software: you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation, either version 3 of the License, or
9 # (at your option) any later version.
10 # .
11 # This package is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
15 # .
16 # You should have received a copy of the GNU General Public License
17 # along with this program. If not, see <http://www.gnu.org/licenses/>.
18 # .
19 # On Debian systems, the complete text of the GNU General
20 # Public License version 3 can be found in "/usr/share/common-licenses/GPL-3".
21
22
23 use strict;
24 use Getopt::Std;
25
26 my $execname = 'apt-installed-status';
27 my $version = '1.1';
28
29
30 ##########################
31 # HANDLE DATA COLLECTION #
32 ##########################
33
34 # Global variables to hold data about all currently installed packages and
35 # all available packages in apt archives.
36
37 # installed_packages: hash
38 # package name: reference to array
39 # counter: reference to hash
40 # 'package': string: package name (same as the primary hash key)
41 # 'binpackage': string: binary package name (may contain architecture)
42 # 'architecture': string: architecture
43 # 'version': string: version
44 # 'status': string: package status
45 my %installed_packages;
46
47 # package_lists: hash
48 # list: reference to hash
49 # package name: reference to array
50 # counter: reference to hash
51 # 'package': string: package name (same as the primary hash key)
52 # 'architecture': string: architecture
53 # 'version': string: version
54 # 'multiarch': string: package multi-arch option (not always available)
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;
61
62
63 # Read a package list file and save it into global variable %package_lists.
64 # Parameter 1: $file: File name (within /var/lib/apt/lists) of the package list
65 # Returns: Nothing
66 # Side effects: Fills in global variabale $package_lists{$file}
67 sub read_package_list
68 {
69 my ($file) = @_;
70 my ($entry,$package);
71 open(FILE, '/var/lib/apt/lists/'.$file) or die "Can't open $file: $!";
72 while (<FILE>) {
73 chomp;
74 ($package) = /^Package:\s*(.*)$/ if /^Package:/;
75 ($entry->{'architecture'}) = /^Architecture:\s*(.*)$/ if /^Architecture:/;
76 ($entry->{'version'}) = /^Version:\s*(.*)$/ if /^Version:/;
77 ($entry->{'multiarch'}) = /^Multi-Arch:\s*(.*)$/ if /^Multi-Arch:/;
78 if (/^\s*$/ and defined($package)) {
79 $entry->{'package'} = $package;
80 push (@{$package_lists{$file}->{$package}}, $entry);
81 undef($entry);
82 undef($package);
83 }
84 }
85 if (defined($entry)) {
86 push (@{$package_lists{$file}->{$package}}, $entry);
87 }
88 close(FILE);
89 }
90
91 # Read all package list files and save them into global variable %package_lists.
92 # Parameters: None
93 # Returns: Nothing
94 # Side effects: Fills in global variabale $package_lists
95 sub read_all_package_lists
96 {
97 opendir(DIR, '/var/lib/apt/lists') or die "Can't opendir: $!";
98 while (defined(my $file = readdir(DIR))) {
99 read_package_list($file) if $file =~ /_Packages$/
100 }
101 closedir(DIR);
102 }
103
104 # Read all installed packages and save them into global variable %installed_packages
105 # Parameters: None
106 # Returns: Nothing
107 # Side effects: Fills in global variabale $package_lists
108 sub read_installed_packages
109 {
110 open(FILE,"dpkg-query -W -f'\${status}\t\${package}\t\${binary:package}\t\${version}\t\${architecture}\n'|") or die "Can't open pipe to dpkq-query: $!";
111 while (<FILE>) {
112 chomp;
113 my ($status, $package, $binpackage,$version,$architecture) = split "\t";
114 push @{$installed_packages{$package}},{ 'status' => $status,
115 'binpackage' => $binpackage,
116 'version' => $version,
117 'package' => $package,
118 'architecture' => $architecture };
119 }
120 close FILE;
121 }
122
123 # Try to locate a package in the archive lists, matching name, architecture
124 # and version.
125 # Parameters: $package_data: reference to a hash containing the package data
126 # Returns: An array of lists in which this package is available
127 sub find_package
128 {
129 my ($package_data) = @_;
130 my @lists_found = ();
131 foreach my $listname (keys %package_lists) {
132 if (exists ($package_lists{$listname}->{$package_data->{'package'}})) {
133 foreach my $entry (@{$package_lists{$listname}->{$package_data->{'package'}}}) {
134 if ($entry->{'architecture'} eq $package_data->{'architecture'} and $entry->{'version'} eq $package_data->{'version'}) {
135 push @lists_found,$listname;
136 last;
137 }
138 }
139 }
140 }
141 return \@lists_found;
142 }
143
144 # Determine for all installed packages in which archives they are found
145 # Parameters: None
146 # Returns: Nothing
147 # Side effects: Fills in global variabale $installed_packages
148 sub find_all_packages
149 {
150 foreach my $package_name (keys %installed_packages) {
151 foreach my $entry (@{$installed_packages{$package_name}}) {
152 $entry->{'lists'} = find_package($entry);
153 }
154 }
155 }
156
157 # Fill all global variables
158 sub init
159 {
160 read_installed_packages();
161 read_all_package_lists();
162 find_all_packages();
163 }
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
178
179 ###############
180 # OUTPUT DATA #
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 }
219
220 # Go through the list of all packages and call a subroutine on each installed
221 # package.
222 # Parameter 1: $sub: Reference to the subroutine to call
223 # Each call gets two parameters: the entry and $long
224 # Parameter 2..: @params: All other parameters
225 # Returns: Nothing
226 # Side effects: Generates output on STDOUT
227 sub iterate_through_packages {
228 my ($sub, @params) = @_;
229 foreach my $package_name (sort keys %installed_packages) {
230 foreach my $entry (@{$installed_packages{$package_name}}) {
231 if ($entry->{status} eq 'install ok installed') {
232 &$sub($entry, @params)
233 }
234 }
235 }
236 }
237
238 # Print an entry, either with or without its archives
239 # Parameter 1: $entry: a hash reference containing keys package, architecture
240 # and version (as well as lists if $long is true)
241 # Parameter 2: $long: whether to print the archives too
242 # Returns: nothing
243 # Side effects: Generates output on STDOUT
244 sub print_item
245 {
246 my ($entry, $long) = @_;
247 if ($long) {
248 print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n";
249 } else {
250 print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n";
251 }
252 }
253
254 # Print all packages, including archives
255 sub print_all
256 {
257 iterate_through_packages(\&print_item, 1);
258 }
259
260
261 # Print only those packages that have no archive associated with them
262 sub print_orphans
263 {
264 iterate_through_packages(\&print_orphans_item);
265 }
266
267 # Callback: check whether an entry is an orphan and if so print it
268 sub print_orphans_item
269 {
270 my ($entry) = @_;
271 if (! @{$entry->{lists}}) {
272 print_item($entry, 0);
273 }
274 }
275
276 # Print those packages which are only in the specified archives
277 sub print_archives_only
278 {
279 my ($archives,$long) = @_;
280 my %archives;
281 foreach my $archive (split (/,/,$archives)) {
282 $archives{$archive} = 1;
283 }
284 iterate_through_packages(\&print_archives_only_item, \%archives, $long);
285 }
286
287 # Callback: print an entry if it is only in the specified archives
288 sub print_archives_only_item
289 {
290 my ($entry,$archives, $long) = @_;
291 my $valid = 1;
292 foreach my $list (@{$entry->{lists}}) {
293 if (! exists($archives->{$list})) {
294 $valid = 0;
295 last;
296 }
297 }
298 if ($valid and @{$entry->{lists}}) {
299 print_item($entry, $long)
300 }
301 }
302
303 # Print those packages which are only in the archives specified through a
304 # regular expression
305 sub print_archives_only_regexp
306 {
307 my ($archives_regexp,$long) = @_;
308 iterate_through_packages(\&print_archives_only_regexp_item, $archives_regexp, $long);
309 }
310
311 # Callback: print an entry if it is only in the archives specified through a
312 # regular expression
313 sub print_archives_only_regexp_item
314 {
315 my ($entry, $archives_regexp, $long) = @_;
316 my $valid = 1;
317 foreach my $list (@{$entry->{lists}}) {
318 if (! ($list =~ /$archives_regexp/)) {
319 $valid = 0;
320 last;
321 }
322 }
323 if ($valid and @{$entry->{lists}}) {
324 print_item($entry, $long)
325 }
326 }
327
328 # Print those packages which are not in the specified archives
329 sub print_archives_except
330 {
331 my ($archives,$long) = @_;
332 my %archives;
333 foreach my $archive (split (/,/,$archives)) {
334 $archives{$archive} = 1;
335 }
336 iterate_through_packages(\&print_archives_except_item, \%archives, $long);
337 }
338
339 # Callback: print an entry if it is not in the specified archives
340 sub print_archives_except_item
341 {
342 my ($entry,$archives, $long) = @_;
343 my $valid = 1;
344 foreach my $list (@{$entry->{lists}}) {
345 if (exists($archives->{$list})) {
346 $valid = 0;
347 last;
348 }
349 }
350 if ($valid and @{$entry->{lists}}) {
351 print_item($entry, $long)
352 }
353 }
354
355 # Print those packages which are not in the archives specified through a
356 # regular expression
357 sub print_archives_except_regexp
358 {
359 my ($archives_regexp,$long) = @_;
360 iterate_through_packages(\&print_archives_except_regexp_item, $archives_regexp, $long);
361 }
362
363 # Callback: print an entry if it is not in the archives specified through a
364 # regular expression
365 sub print_archives_except_regexp_item
366 {
367 my ($entry, $archives_regexp, $long) = @_;
368 my $valid = 1;
369 foreach my $list (@{$entry->{lists}}) {
370 if ($list =~ /$archives_regexp/) {
371 $valid = 0;
372 last;
373 }
374 }
375 if ($valid and @{$entry->{lists}}) {
376 print_item($entry, $long)
377 }
378 }
379
380 #########################
381 # COMMAND LINE HANDLING #
382 #########################
383
384 sub print_help
385 {
386 print STDERR "$execname [OPTION]\n";
387 print STDERR " -h: help text and exit\n";
388 print STDERR " -V: print version and exit\n";
389 print STDERR " -o: orphans: packages that are not in any archive\n";
390 print STDERR " -a ARCHS: archives: list all packages that are only in one of the listed\n";
391 print STDERR " archives (seperated by commas)\n";
392 print STDERR " -A ARCHREGEXP: archives: list all packages that are only in archives\n";
393 print STDERR " that match the regular expression\n";
394 print STDERR " -x ARCHS: except: list all packages that are not in one of the listed\n";
395 print STDERR " archives (seperated by commas)\n";
396 print STDERR " -X ARCHREGEXP: except: list all packages that are not in archives\n";
397 print STDERR " that match the regular expression\n";
398 print STDERR " -l: long: print archives too\n";
399 print STDERR " -L: list: print archives that are selected instead of packages\n";
400
401 print STDERR "Default: print all packages and sources\n";
402 }
403
404 sub print_version
405 {
406 print STDERR "$execname $version\n";
407 }
408
409 sub HELP_MESSAGE
410 {
411 print_help();
412 exit 0;
413 }
414
415 $Getopt::Std::STANDARD_HELP_VERSION=1;
416
417 our $VERSION=$version;
418 my %options;
419 if (! getopts('hVoLla:A:x:X:',\%options))
420 {
421 print_help();
422 exit 1;
423 }
424 my $long=0;
425 my $names_only=0;
426
427 if ($options{'h'}) {
428 print_help();
429 exit 0;
430 }
431 if ($options{'V'}) {
432 print_version();
433 exit 0;
434 }
435 if ($options{'L'}) {
436 $names_only=1;
437 }
438 if ($names_only) {
439 init_names();
440 } else {
441 init();
442 }
443 if ($options{'o'}) {
444 print_orphans();
445 exit 0;
446 }
447 if ($options{l}) {
448 $long = 1;
449 }
450 if ($options{a}) {
451 if ($names_only) {
452 print_archive_names_only($options{a});
453 } else {
454 print_archives_only($options{a},$long);
455 }
456 exit 0;
457 }
458 if ($options{A}) {
459 if ($names_only) {
460 print_archive_names_only_regexp($options{A});
461 } else {
462 print_archives_only_regexp($options{A},$long);
463 }
464 exit 0;
465 }
466 if ($options{x}) {
467 if ($names_only) {
468 print_archive_names_except($options{x});
469 } else {
470 print_archives_except($options{x},$long);
471 }
472 exit 0;
473 }
474 if ($options{X}) {
475 if ($names_only) {
476 print_archive_names_except($options{X});
477 } else {
478 print_archives_except_regexp($options{X},$long);
479 }
480 exit 0;
481 }
482 if ($names_only) {
483 print_archive_names()
484 } else {
485 print_all();
486 }
487
488
489 # vim:sw=2:ft=perl:expandtab:

Properties

Name Value
svn:executable *

frodo@frodo.looijaard.name
ViewVC Help
Powered by ViewVC 1.1.26