/[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 332 - (show annotations)
Thu Jun 12 09:52:01 2014 UTC (6 years, 2 months ago) by frodo
File size: 10653 byte(s)
(Frodo) Add -X/-x option (except) and restructure to use callbacks

1 #!/usr/bin/perl -w
2
3 use strict;
4 use Getopt::Std;
5
6 use Data::Dumper;
7
8 my $execname = 'apt-installed-status';
9 my $version = '1.0';
10
11
12 ##########################
13 # HANDLE DATA COLLECTION #
14 ##########################
15
16 # Global variables to hold data about all currently installed packages and
17 # all available packages in apt archives.
18
19 # installed_packages: hash
20 # package name: reference to array
21 # counter: reference to hash
22 # 'package': string: package name (same as the primary hash key)
23 # 'binpackage': string: binary package name (may contain architecture)
24 # 'architecture': string: architecture
25 # 'version': string: version
26 # 'status': string: package status
27 my %installed_packages;
28
29 # package_lists: hash
30 # list: reference to hash
31 # package name: reference to array
32 # counter: reference to hash
33 # 'package': string: package name (same as the primary hash key)
34 # 'architecture': string: architecture
35 # 'version': string: version
36 # 'multiarch': string: package multi-arch option (not always available)
37 my %package_lists;
38
39
40 # Read a package list file and save it into global variable %package_lists.
41 # Parameter 1: $file: File name (within /var/lib/apt/lists) of the package list
42 # Returns: Nothing
43 # Side effects: Fills in global variabale $package_lists{$file}
44 sub read_package_list
45 {
46 my ($file) = @_;
47 my ($entry,$package);
48 open(FILE, '/var/lib/apt/lists/'.$file) or die "Can't open $file: $!";
49 while (<FILE>) {
50 chomp;
51 ($package) = /^Package:\s*(.*)$/ if /^Package:/;
52 ($entry->{'architecture'}) = /^Architecture:\s*(.*)$/ if /^Architecture:/;
53 ($entry->{'version'}) = /^Version:\s*(.*)$/ if /^Version:/;
54 ($entry->{'multiarch'}) = /^Multi-Arch:\s*(.*)$/ if /^Multi-Arch:/;
55 if (/^\s*$/ and defined($package)) {
56 $entry->{'package'} = $package;
57 push (@{$package_lists{$file}->{$package}}, $entry);
58 undef($entry);
59 undef($package);
60 }
61 }
62 if (defined($entry)) {
63 push (@{$package_lists{$file}->{$package}}, $entry);
64 }
65 close(FILE);
66 }
67
68 # Read all package list files and save them into global variable %package_lists.
69 # Parameters: None
70 # Returns: Nothing
71 # Side effects: Fills in global variabale $package_lists
72 sub read_all_package_lists
73 {
74 opendir(DIR, '/var/lib/apt/lists') or die "Can't opendir: $!";
75 while (defined(my $file = readdir(DIR))) {
76 read_package_list($file) if $file =~ /_Packages$/
77 }
78 closedir(DIR);
79 }
80
81 # Read all installed packages and save them into global variable %installed_packages
82 # Parameters: None
83 # Returns: Nothing
84 # Side effects: Fills in global variabale $package_lists
85 sub read_installed_packages
86 {
87 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: $!";
88 while (<FILE>) {
89 chomp;
90 my ($status, $package, $binpackage,$version,$architecture) = split "\t";
91 push @{$installed_packages{$package}},{ 'status' => $status,
92 'binpackage' => $binpackage,
93 'version' => $version,
94 'package' => $package,
95 'architecture' => $architecture };
96 }
97 close FILE;
98 }
99
100 # Try to locate a package in the archive lists, matching name, architecture
101 # and version.
102 # Parameters: $package_data: reference to a hash containing the package data
103 # Returns: An array of lists in which this package is available
104 sub find_package
105 {
106 my ($package_data) = @_;
107 my @lists_found = ();
108 foreach my $listname (keys %package_lists) {
109 if (exists ($package_lists{$listname}->{$package_data->{'package'}})) {
110 foreach my $entry (@{$package_lists{$listname}->{$package_data->{'package'}}}) {
111 if ($entry->{'architecture'} eq $package_data->{'architecture'} and $entry->{'version'} eq $package_data->{'version'}) {
112 push @lists_found,$listname;
113 last;
114 }
115 }
116 }
117 }
118 return \@lists_found;
119 }
120
121 # Determine for all installed packages in which archives they are found
122 # Parameters: None
123 # Returns: Nothing
124 # Side effects: Fills in global variabale $installed_packages
125 sub find_all_packages
126 {
127 foreach my $package_name (keys %installed_packages) {
128 foreach my $entry (@{$installed_packages{$package_name}}) {
129 $entry->{'lists'} = find_package($entry);
130 }
131 }
132 }
133
134 # Fill all global variables
135 sub init
136 {
137 read_installed_packages();
138 read_all_package_lists();
139 find_all_packages();
140 }
141
142
143 ###############
144 # OUTPUT DATA #
145 ###############
146
147 # Go through the list of all packages and call a subroutine on each installed
148 # package.
149 # Parameter 1: $sub: Reference to the subroutine to call
150 # Each call gets two parameters: the entry and $long
151 # Parameter 2..: @params: All other parameters
152 # Returns: Nothing
153 # Side effects: Generates output on STDOUT
154 sub iterate_through_packages {
155 my ($sub, @params) = @_;
156 foreach my $package_name (sort keys %installed_packages) {
157 foreach my $entry (@{$installed_packages{$package_name}}) {
158 if ($entry->{status} eq 'install ok installed') {
159 &$sub($entry, @params)
160 }
161 }
162 }
163 }
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
204 sub print_archives_only
205 {
206 my ($archives,$long) = @_;
207 my %archives;
208 foreach my $archive (split (/,/,$archives)) {
209 $archives{$archive} = 1;
210 }
211 iterate_through_packages(\&print_archives_only_item, \%archives, $long);
212 }
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) = @_;
218 my $valid = 1;
219 foreach my $list (@{$entry->{lists}}) {
220 if (! exists($archives->{$list})) {
221 $valid = 0;
222 last;
223 }
224 }
225 if ($valid and @{$entry->{lists}}) {
226 print_item($entry, $long)
227 }
228 }
229
230 # Print those packages which are only in the archives specified through a
231 # regular expression
232 sub print_archives_only_regexp
233 {
234 my ($archives_regexp,$long) = @_;
235 iterate_through_packages(\&print_archives_only_regexp_item, $archives_regexp, $long);
236 }
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) = @_;
243 my $valid = 1;
244 foreach my $list (@{$entry->{lists}}) {
245 if (! ($list =~ /$archives_regexp/)) {
246 $valid = 0;
247 last;
248 }
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;
275 }
276 }
277 if ($valid and @{$entry->{lists}}) {
278 print_item($entry, $long)
279 }
280 }
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 }
306
307 #########################
308 # COMMAND LINE HANDLING #
309 #########################
310
311 sub print_help
312 {
313 print STDERR "$execname [OPTION]\n";
314 print STDERR " -h: help text and exit\n";
315 print STDERR " -V: print version and exit\n";
316 print STDERR " -o: orphans: packages that are not in any archive\n";
317 print STDERR " -a ARCHS: archives: list all packages that are only in one of the listed\n";
318 print STDERR " archives (seperated by commas)\n";
319 print STDERR " -A ARCHREGEXP: archives: list all packages that are only in archives\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";
325 print STDERR " -l: long: print archives too\n";
326
327 print STDERR "Default: print all packages and sources\n";
328 }
329
330 sub print_version
331 {
332 print STDERR "$execname $version\n";
333 }
334
335 sub HELP_MESSAGE
336 {
337 print_help();
338 exit 0;
339 }
340
341 $Getopt::Std::STANDARD_HELP_VERSION=1;
342
343 our $VERSION=$version;
344 my %options;
345 if (! getopts('hVola:A:x:X:',\%options))
346 {
347 print_help();
348 exit 1;
349 }
350 my $long=0;
351 if ($options{'h'}) {
352 print_help();
353 exit 0;
354 }
355 if ($options{'V'}) {
356 print_version();
357 exit 0;
358 }
359 init();
360 if ($options{'o'}) {
361 print_orphans();
362 exit 0;
363 }
364 if ($options{l}) {
365 $long = 1;
366 }
367 if ($options{a}) {
368 print_archives_only($options{a},$long);
369 exit 0;
370 }
371 if ($options{A}) {
372 print_archives_only_regexp($options{A},$long);
373 exit 0;
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 }
383 print_all;
384
385
386 # vim:sw=2:ft=perl:expandtab:

Properties

Name Value
svn:executable *

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