1 |
frodo |
330 |
#!/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 |
frodo |
332 |
# 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 |
frodo |
330 |
if ($entry->{status} eq 'install ok installed') { |
159 |
frodo |
332 |
&$sub($entry, @params) |
160 |
frodo |
330 |
} |
161 |
|
|
} |
162 |
|
|
} |
163 |
|
|
} |
164 |
|
|
|
165 |
frodo |
332 |
# 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 |
frodo |
330 |
{ |
173 |
frodo |
332 |
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 |
frodo |
330 |
} |
179 |
|
|
} |
180 |
|
|
|
181 |
frodo |
332 |
# 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 |
frodo |
330 |
sub print_archives_only |
205 |
|
|
{ |
206 |
|
|
my ($archives,$long) = @_; |
207 |
|
|
my %archives; |
208 |
|
|
foreach my $archive (split (/,/,$archives)) { |
209 |
|
|
$archives{$archive} = 1; |
210 |
|
|
} |
211 |
frodo |
332 |
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 |
frodo |
330 |
} |
224 |
|
|
} |
225 |
frodo |
332 |
if ($valid and @{$entry->{lists}}) { |
226 |
|
|
print_item($entry, $long) |
227 |
|
|
} |
228 |
frodo |
330 |
} |
229 |
|
|
|
230 |
frodo |
332 |
# Print those packages which are only in the archives specified through a |
231 |
|
|
# regular expression |
232 |
frodo |
330 |
sub print_archives_only_regexp |
233 |
|
|
{ |
234 |
|
|
my ($archives_regexp,$long) = @_; |
235 |
frodo |
332 |
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 |
frodo |
330 |
} |
249 |
|
|
} |
250 |
frodo |
332 |
if ($valid and @{$entry->{lists}}) { |
251 |
|
|
print_item($entry, $long) |
252 |
|
|
} |
253 |
frodo |
330 |
} |
254 |
|
|
|
255 |
frodo |
332 |
# 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 |
frodo |
330 |
|
266 |
frodo |
332 |
# 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 |
frodo |
330 |
######################### |
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 |
frodo |
332 |
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 |
frodo |
330 |
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 |
frodo |
332 |
if (! getopts('hVola:A:x:X:',\%options)) |
346 |
frodo |
330 |
{ |
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 |
frodo |
332 |
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 |
frodo |
330 |
print_all; |
384 |
|
|
|
385 |
|
|
|
386 |
|
|
# vim:sw=2:ft=perl:expandtab: |