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

Diff of /apt-installed-status/trunk/apt-installed-status

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 330 Revision 337
1#!/usr/bin/perl -w 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
2 22
3use strict; 23use strict;
4use Getopt::Std; 24use Getopt::Std;
5 25
6use Data::Dumper;
7
8my $execname = 'apt-installed-status'; 26my $execname = 'apt-installed-status';
9my $version = '1.0'; 27my $version = '1.1';
10 28
11 29
12########################## 30##########################
13# HANDLE DATA COLLECTION # 31# HANDLE DATA COLLECTION #
14########################## 32##########################
… …
33# 'package': string: package name (same as the primary hash key) 51# 'package': string: package name (same as the primary hash key)
34# 'architecture': string: architecture 52# 'architecture': string: architecture
35# 'version': string: version 53# 'version': string: version
36# 'multiarch': string: package multi-arch option (not always available) 54# 'multiarch': string: package multi-arch option (not always available)
37my %package_lists; 55my %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
60my @archive_names;
38 61
39 62
40# 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.
41# 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
42# Returns: Nothing 65# Returns: Nothing
… …
137 read_installed_packages(); 160 read_installed_packages();
138 read_all_package_lists(); 161 read_all_package_lists();
139 find_all_packages(); 162 find_all_packages();
140} 163}
141 164
165# Determine which package archives are available.
166# Parameters: None
167# Returns: Nothing
168# Side effects: Fills in global variabale @archive_names
169sub 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
142 178
143############### 179###############
144# OUTPUT DATA # 180# OUTPUT DATA #
145############### 181###############
146 182
147sub print_orphans 183sub print_archive_names
148{ 184{
149 foreach my $package_data (values %installed_packages) { 185 print join("\n", sort @archive_names)."\n";
150 foreach my $entry (@$package_data) { 186}
151 if ($entry->{status} eq 'install ok installed') { 187
152 if (! @{$entry->{lists}}) { 188sub print_archive_names_only
153 print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n"; 189{
154 } 190 my ($archives) = @_;
155 } 191 my %archives;
192 foreach my $archive (split (/,/,$archives)) {
193 $archives{$archive} = 1;
156 } 194 }
157 } 195 print join("\n", sort (grep { exists $archives{$_} } @archive_names))."\n";
158} 196}
159 197
160sub print_all 198sub print_archive_names_only_regexp
161{ 199{
200 my ($archives_regexp) = @_;
201 print join("\n", sort (grep /$archives_regexp/,@archive_names))."\n";
202}
203
204sub 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
214sub 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
227sub iterate_through_packages {
228 my ($sub, @params) = @_;
162 foreach my $package_name (sort keys %installed_packages) { 229 foreach my $package_name (sort keys %installed_packages) {
163 foreach my $entry (@{$installed_packages{$package_name}}) { 230 foreach my $entry (@{$installed_packages{$package_name}}) {
164 if ($entry->{status} eq 'install ok installed') { 231 if ($entry->{status} eq 'install ok installed') {
165 print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n"; 232 &$sub($entry, @params)
166 } 233 }
167 } 234 }
168 } 235 }
169} 236}
170 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
244sub 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
255sub 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
262sub 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
268sub 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
171sub print_archives_only 277sub print_archives_only
172{ 278{
173 my ($archives,$long) = @_; 279 my ($archives,$long) = @_;
174 my %archives; 280 my %archives;
175 foreach my $archive (split (/,/,$archives)) { 281 foreach my $archive (split (/,/,$archives)) {
176 $archives{$archive} = 1; 282 $archives{$archive} = 1;
177 } 283 }
178 foreach my $package_name (sort keys %installed_packages) { 284 iterate_through_packages(\&print_archives_only_item, \%archives, $long);
179 foreach my $entry (@{$installed_packages{$package_name}}) { 285}
180 if ($entry->{status} eq 'install ok installed') { 286
287# Callback: print an entry if it is only in the specified archives
288sub print_archives_only_item
289{
290 my ($entry,$archives, $long) = @_;
181 my $valid = 1; 291 my $valid = 1;
182 my $nr=0;
183 foreach my $list (@{$entry->{lists}}) { 292 foreach my $list (@{$entry->{lists}}) {
184 $nr++;
185 if (! exists($archives{$list})) { 293 if (! exists($archives->{$list})) {
186 $valid = 0; 294 $valid = 0;
187 last; 295 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 } 296 }
198 } 297 }
298 if ($valid and @{$entry->{lists}}) {
299 print_item($entry, $long)
199 } 300 }
200} 301}
201 302
303# Print those packages which are only in the archives specified through a
304# regular expression
202sub print_archives_only_regexp 305sub print_archives_only_regexp
203{ 306{
204 my ($archives_regexp,$long) = @_; 307 my ($archives_regexp,$long) = @_;
205 foreach my $package_name (sort keys %installed_packages) { 308 iterate_through_packages(\&print_archives_only_regexp_item, $archives_regexp, $long);
206 foreach my $entry (@{$installed_packages{$package_name}}) { 309}
207 if ($entry->{status} eq 'install ok installed') { 310
311# Callback: print an entry if it is only in the archives specified through a
312# regular expression
313sub print_archives_only_regexp_item
314{
315 my ($entry, $archives_regexp, $long) = @_;
208 my $valid = 1; 316 my $valid = 1;
209 my $nr=0;
210 foreach my $list (@{$entry->{lists}}) { 317 foreach my $list (@{$entry->{lists}}) {
211 $nr++;
212 if (! ($list =~ /$archives_regexp/)) { 318 if (! ($list =~ /$archives_regexp/)) {
213 $valid = 0; 319 $valid = 0;
214 last; 320 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 } 321 }
225 } 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
329sub 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
340sub 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;
226 } 348 }
349 }
350 if ($valid and @{$entry->{lists}}) {
351 print_item($entry, $long)
352 }
227} 353}
228 354
355# Print those packages which are not in the archives specified through a
356# regular expression
357sub 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
365sub 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}
229 379
230######################### 380#########################
231# COMMAND LINE HANDLING # 381# COMMAND LINE HANDLING #
232######################### 382#########################
233 383
… …
239 print STDERR " -o: orphans: packages that are not in any archive\n"; 389 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"; 390 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"; 391 print STDERR " archives (seperated by commas)\n";
242 print STDERR " -A ARCHREGEXP: archives: list all packages that are only in archives\n"; 392 print STDERR " -A ARCHREGEXP: archives: list all packages that are only in archives\n";
243 print STDERR " that match the regular expression\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";
244 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";
245 400
246 print STDERR "Default: print all packages and sources\n"; 401 print STDERR "Default: print all packages and sources\n";
247} 402}
248 403
249sub print_version 404sub print_version
… …
259 414
260$Getopt::Std::STANDARD_HELP_VERSION=1; 415$Getopt::Std::STANDARD_HELP_VERSION=1;
261 416
262our $VERSION=$version; 417our $VERSION=$version;
263my %options; 418my %options;
264if (! getopts('hVola:A:',\%options)) 419if (! getopts('hVoLla:A:x:X:',\%options))
265{ 420{
266 print_help(); 421 print_help();
267 exit 1; 422 exit 1;
268} 423}
269my $long=0; 424my $long=0;
425my $names_only=0;
426
270if ($options{'h'}) { 427if ($options{'h'}) {
271 print_help(); 428 print_help();
272 exit 0; 429 exit 0;
273} 430}
274if ($options{'V'}) { 431if ($options{'V'}) {
275 print_version(); 432 print_version();
276 exit 0; 433 exit 0;
277} 434}
435if ($options{'L'}) {
436 $names_only=1;
437}
438if ($names_only) {
439 init_names();
440} else {
278init(); 441 init();
442}
279if ($options{'o'}) { 443if ($options{'o'}) {
280 print_orphans(); 444 print_orphans();
281 exit 0; 445 exit 0;
282} 446}
283if ($options{l}) { 447if ($options{l}) {
284 $long = 1; 448 $long = 1;
285} 449}
286if ($options{a}) { 450if ($options{a}) {
451 if ($names_only) {
452 print_archive_names_only($options{a});
453 } else {
287 print_archives_only($options{a},$long); 454 print_archives_only($options{a},$long);
455 }
288 exit 0; 456 exit 0;
289} 457}
290if ($options{A}) { 458if ($options{A}) {
459 if ($names_only) {
460 print_archive_names_only_regexp($options{A});
461 } else {
291 print_archives_only_regexp($options{A},$long); 462 print_archives_only_regexp($options{A},$long);
463 }
292 exit 0; 464 exit 0;
293} 465}
466if ($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}
474if ($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}
482if ($names_only) {
483 print_archive_names()
484} else {
294print_all; 485 print_all();
486}
295 487
296 488
297# vim:sw=2:ft=perl:expandtab: 489# vim:sw=2:ft=perl:expandtab:
Legend:
Removed from v.330  
changed lines
  Added in v.337
frodo@frodo.looijaard.name
 ViewVC Help
Powered by ViewVC 1.1.26