Annotation of /apt-installed-status/trunk/apt-installed-status

#!/usr/bin/perl -w

# Copyright (c) 2014 by Frodo Looijaard <frodo@frodo.looijaard.name>
# 
# License: GPL-3.0+
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# .
# This package is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# .
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
# .
# On Debian systems, the complete text of the GNU General
# Public License version 3 can be found in "/usr/share/common-licenses/GPL-3".


use strict;
use Getopt::Std;

my $execname = 'apt-installed-status';
my $version = '1.1';


##########################
# HANDLE DATA COLLECTION #
##########################

# Global variables to hold data about all currently installed packages and
# all available packages in apt archives.

# installed_packages: hash 
#   package name: reference to array
#     counter: reference to hash
#       'package': string: package name (same as the primary hash key)
#       'binpackage': string: binary package name (may contain architecture)
#       'architecture': string: architecture
#       'version': string: version
#       'status': string: package status
my %installed_packages;

# package_lists: hash 
#   list: reference to hash
#     package name: reference to array
#       counter: reference to hash
#         'package': string: package name (same as the primary hash key)
#         'architecture': string: architecture
#         'version': string: version
#         'multiarch': string: package multi-arch option (not always available)
my %package_lists;

# When only the names of the package lists is asked for, we fill this variable.
# archives: array
#   counter: string: name of the archive
my @archive_names;


# Read a package list file and save it into global variable %package_lists.
# Parameter 1: $file: File name (within /var/lib/apt/lists) of the package list
# Returns: Nothing
# Side effects: Fills in global variabale $package_lists{$file}
sub read_package_list
{
  my ($file) = @_;
  my ($entry,$package);
  open(FILE, '/var/lib/apt/lists/'.$file) or die "Can't open $file: $!";
  while (<FILE>) {
    chomp;
    ($package) = /^Package:\s*(.*)$/ if /^Package:/;
    ($entry->{'architecture'}) = /^Architecture:\s*(.*)$/ if /^Architecture:/;
    ($entry->{'version'}) = /^Version:\s*(.*)$/ if /^Version:/;
    ($entry->{'multiarch'}) = /^Multi-Arch:\s*(.*)$/ if /^Multi-Arch:/;
    if (/^\s*$/ and defined($package)) {
      $entry->{'package'} = $package;
      push (@{$package_lists{$file}->{$package}}, $entry);
      undef($entry);
      undef($package);
    }
  }
  if (defined($entry)) {
    push (@{$package_lists{$file}->{$package}}, $entry);
  }
  close(FILE);
}

# Read all package list files and save them into global variable %package_lists.
# Parameters: None
# Returns: Nothing
# Side effects: Fills in global variabale $package_lists
sub read_all_package_lists
{
  opendir(DIR, '/var/lib/apt/lists') or die "Can't opendir: $!";
  while (defined(my $file = readdir(DIR))) {
    read_package_list($file) if $file =~ /_Packages$/
  }
  closedir(DIR);
}

# Read all installed packages and save them into global variable %installed_packages
# Parameters: None
# Returns: Nothing
# Side effects: Fills in global variabale $package_lists
sub read_installed_packages
{
  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: $!";
  while (<FILE>) {
    chomp;
    my ($status, $package, $binpackage,$version,$architecture) = split "\t";
    push @{$installed_packages{$package}},{ 'status' => $status, 
                                      'binpackage' => $binpackage, 
                                      'version' => $version, 
                                      'package' => $package,
                                      'architecture' => $architecture };
  }
  close FILE;
}

# Try to locate a package in the archive lists, matching name, architecture
#   and version.
# Parameters: $package_data: reference to a hash containing the package data
# Returns: An array of lists in which this package is available
sub find_package
{
  my ($package_data) = @_;
  my @lists_found = ();
  foreach my $listname (keys %package_lists) {
    if (exists ($package_lists{$listname}->{$package_data->{'package'}})) {
      foreach my $entry (@{$package_lists{$listname}->{$package_data->{'package'}}}) {
        if ($entry->{'architecture'} eq $package_data->{'architecture'} and $entry->{'version'} eq $package_data->{'version'}) {
          push @lists_found,$listname;
          last;
        }
      }
    }
  }
  return \@lists_found;
}

# Determine for all installed packages in which archives they are found
# Parameters: None
# Returns: Nothing
# Side effects: Fills in global variabale $installed_packages
sub find_all_packages
{
  foreach my $package_name (keys %installed_packages) {
    foreach my $entry (@{$installed_packages{$package_name}}) {
      $entry->{'lists'} = find_package($entry);
    }
  }
}

# Fill all global variables
sub init
{
  read_installed_packages();
  read_all_package_lists();
  find_all_packages();
}

# Determine which package archives are available.
# Parameters: None
# Returns: Nothing
# Side effects: Fills in global variabale @archive_names
sub init_names
{
  opendir(DIR, '/var/lib/apt/lists') or die "Can't opendir: $!";
  while (defined(my $file = readdir(DIR))) {
    push (@archive_names,$file) if $file =~ /_Packages$/
  }
  closedir(DIR);
}


###############
# OUTPUT DATA #
###############

sub print_archive_names
{
  print join("\n", sort @archive_names)."\n";
}

sub print_archive_names_only
{
  my ($archives) = @_;
  my %archives;
  foreach my $archive (split (/,/,$archives)) {
    $archives{$archive} = 1;
  }
  print join("\n", sort (grep { exists $archives{$_} } @archive_names))."\n";
}

sub print_archive_names_only_regexp
{
  my ($archives_regexp) = @_;
  print join("\n", sort (grep /$archives_regexp/,@archive_names))."\n";
}

sub print_archive_names_except
{
  my ($archives) = @_;
  my %archives;
  foreach my $archive (split (/,/,$archives)) {
    $archives{$archive} = 1;
  }
  print join("\n", sort (grep { ! exists $archives{$_} } @archive_names))."\n";
}

sub print_archive_names_except_regexp
{
  my ($archives_regexp) = @_;
  print join("\n", sort (grep !/$archives_regexp/,@archive_names))."\n";
}

# Go through the list of all packages and call a subroutine on each installed
# package.
# Parameter 1: $sub: Reference to the subroutine to call
#   Each call gets two parameters: the entry and $long
# Parameter 2..: @params: All other parameters
# Returns: Nothing
# Side effects: Generates output on STDOUT
sub iterate_through_packages {
  my ($sub, @params) = @_;
  foreach my $package_name (sort keys %installed_packages) {
    foreach my $entry (@{$installed_packages{$package_name}}) {
      if ($entry->{status} eq 'install ok installed') {
        &$sub($entry, @params)
      }
    }
  }
}

# Print an entry, either with or without its archives
# Parameter 1: $entry: a hash reference containing keys package, architecture
#   and version (as well as lists if $long is true)
# Parameter 2: $long: whether to print the archives too
# Returns: nothing
# Side effects: Generates output on STDOUT
sub print_item 
{
  my ($entry, $long) = @_;
  if ($long) { 
    print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n";
  } else {
    print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n";
  }
}

# Print all packages, including archives
sub print_all 
{
  iterate_through_packages(\&print_item, 1);
}


# Print only those packages that have no archive associated with them
sub print_orphans
{
  iterate_through_packages(\&print_orphans_item);
}

# Callback: check whether an entry is an orphan and if so print it
sub print_orphans_item
{
  my ($entry) = @_;
  if (! @{$entry->{lists}}) {
    print_item($entry, 0);
  }
}

# Print those packages which are only in the specified archives
sub print_archives_only
{
  my ($archives,$long) = @_;
  my %archives;
  foreach my $archive (split (/,/,$archives)) {
    $archives{$archive} = 1;
  }
  iterate_through_packages(\&print_archives_only_item, \%archives, $long);
}

# Callback: print an entry if it is only in the specified archives
sub print_archives_only_item
{
  my ($entry,$archives, $long) = @_;
  my $valid = 1;
  foreach my $list (@{$entry->{lists}}) {
    if (! exists($archives->{$list})) {
      $valid = 0;
      last;
    }
  }
  if ($valid and @{$entry->{lists}}) {
    print_item($entry, $long)
  }
}

# Print those packages which are only in the archives specified through a 
# regular expression
sub print_archives_only_regexp
{
  my ($archives_regexp,$long) = @_;
  iterate_through_packages(\&print_archives_only_regexp_item, $archives_regexp, $long);
}

# Callback: print an entry if it is only in the archives specified through a 
# regular expression
sub print_archives_only_regexp_item
{
  my ($entry, $archives_regexp, $long) = @_;
  my $valid = 1;
  foreach my $list (@{$entry->{lists}}) {
    if (! ($list =~ /$archives_regexp/)) {
      $valid = 0;
      last;
    }
  }
  if ($valid and @{$entry->{lists}}) {
    print_item($entry, $long)
  }
}

# Print those packages which are not in the specified archives
sub print_archives_except
{
  my ($archives,$long) = @_;
  my %archives;
  foreach my $archive (split (/,/,$archives)) {
    $archives{$archive} = 1;
  }
  iterate_through_packages(\&print_archives_except_item, \%archives, $long);
}

# Callback: print an entry if it is not in the specified archives
sub print_archives_except_item
{
  my ($entry,$archives, $long) = @_;
  my $valid = 1;
  foreach my $list (@{$entry->{lists}}) {
    if (exists($archives->{$list})) {
      $valid = 0;
      last;
    }
  }
  if ($valid and @{$entry->{lists}}) {
    print_item($entry, $long)
  }
}

# Print those packages which are not in the archives specified through a 
# regular expression
sub print_archives_except_regexp
{
  my ($archives_regexp,$long) = @_;
  iterate_through_packages(\&print_archives_except_regexp_item, $archives_regexp, $long);
}

# Callback: print an entry if it is not in the archives specified through a 
# regular expression
sub print_archives_except_regexp_item
{
  my ($entry, $archives_regexp, $long) = @_;
  my $valid = 1;
  foreach my $list (@{$entry->{lists}}) {
    if ($list =~ /$archives_regexp/) {
      $valid = 0;
      last;
    }
  }
  if ($valid and @{$entry->{lists}}) {
    print_item($entry, $long)
  }
}

#########################
# COMMAND LINE HANDLING #
#########################

sub print_help
{
  print STDERR "$execname [OPTION]\n";
  print STDERR "  -h: help text and exit\n";
  print STDERR "  -V: print version and exit\n";
  print STDERR "  -o: orphans: packages that are not in any archive\n";
  print STDERR "  -a ARCHS: archives: list all packages that are only in one of the listed\n";
  print STDERR "        archives (seperated by commas)\n";
  print STDERR "  -A ARCHREGEXP: archives: list all packages that are only in archives\n";
  print STDERR "        that match the regular expression\n";
  print STDERR "  -x ARCHS: except: list all packages that are not in one of the listed\n";
  print STDERR "        archives (seperated by commas)\n";
  print STDERR "  -X ARCHREGEXP: except: list all packages that are not in archives\n";
  print STDERR "        that match the regular expression\n";
  print STDERR "  -l: long: print archives too\n";
  print STDERR "  -L: list: print archives that are selected instead of packages\n";

  print STDERR "Default: print all packages and sources\n";
}

sub print_version 
{
  print STDERR "$execname $version\n";
}

sub HELP_MESSAGE
{
  print_help();
  exit 0;
}

$Getopt::Std::STANDARD_HELP_VERSION=1;

our $VERSION=$version;
my %options;
if (! getopts('hVoLla:A:x:X:',\%options))
{
  print_help();
  exit 1;
}
my $long=0;
my $names_only=0;

if ($options{'h'}) {
  print_help();
  exit 0;
}
if ($options{'V'}) {
  print_version();
  exit 0;
}
if ($options{'L'}) {
  $names_only=1;
}
if ($names_only) {
  init_names();
} else {
  init();
}
if ($options{'o'}) {
  print_orphans();
  exit 0;
}
if ($options{l}) {
  $long = 1;
}
if ($options{a}) {
  if ($names_only) {
    print_archive_names_only($options{a});
  } else {
    print_archives_only($options{a},$long);
  }
  exit 0;
}
if ($options{A}) {
  if ($names_only) {
    print_archive_names_only_regexp($options{A});
  } else {
    print_archives_only_regexp($options{A},$long);
  }
  exit 0;
}
if ($options{x}) {
  if ($names_only) {
    print_archive_names_except($options{x});
  } else {
    print_archives_except($options{x},$long);
  }
  exit 0;
}
if ($options{X}) {
  if ($names_only) {
    print_archive_names_except($options{X});
  } else {
    print_archives_except_regexp($options{X},$long);
  }
  exit 0;
}
if ($names_only) {
  print_archive_names()
} else {
  print_all();
}


# vim:sw=2:ft=perl:expandtab:
1	frodo	330	#!/usr/bin/perl -w
2
3	frodo	333	# 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	frodo	330	use strict;
24			use Getopt::Std;
25
26			my $execname = 'apt-installed-status';
27	frodo	337	my $version = '1.1';
28	frodo	330
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	frodo	337	# 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	frodo	330
62	frodo	337
63	frodo	330	# 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	frodo	337	# 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	frodo	330
178	frodo	337
179	frodo	330	###############
180			# OUTPUT DATA #
181			###############
182
183	frodo	337	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	frodo	332	# 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	frodo	330	if ($entry->{status} eq 'install ok installed') {
232	frodo	332	&$sub($entry, @params)
233	frodo	330	}
234			}
235			}
236			}
237
238	frodo	332	# 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	frodo	330	{
246	frodo	332	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	frodo	330	}
252			}
253
254	frodo	332	# 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	frodo	330	sub print_archives_only
278			{
279			my ($archives,$long) = @_;
280			my %archives;
281			foreach my $archive (split (/,/,$archives)) {
282			$archives{$archive} = 1;
283			}
284	frodo	332	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	frodo	330	}
297			}
298	frodo	332	if ($valid and @{$entry->{lists}}) {
299			print_item($entry, $long)
300			}
301	frodo	330	}
302
303	frodo	332	# Print those packages which are only in the archives specified through a
304			# regular expression
305	frodo	330	sub print_archives_only_regexp
306			{
307			my ($archives_regexp,$long) = @_;
308	frodo	332	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	frodo	330	}
322			}
323	frodo	332	if ($valid and @{$entry->{lists}}) {
324			print_item($entry, $long)
325			}
326	frodo	330	}
327
328	frodo	332	# 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	frodo	330
339	frodo	332	# 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	frodo	330	#########################
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	frodo	332	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	frodo	330	print STDERR " -l: long: print archives too\n";
399	frodo	337	print STDERR " -L: list: print archives that are selected instead of packages\n";
400	frodo	330
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	frodo	337	if (! getopts('hVoLla:A:x:X:',\%options))
420	frodo	330	{
421			print_help();
422			exit 1;
423			}
424			my $long=0;
425	frodo	337	my $names_only=0;
426
427	frodo	330	if ($options{'h'}) {
428			print_help();
429			exit 0;
430			}
431			if ($options{'V'}) {
432			print_version();
433			exit 0;
434			}
435	frodo	337	if ($options{'L'}) {
436			$names_only=1;
437			}
438			if ($names_only) {
439			init_names();
440			} else {
441			init();
442			}
443	frodo	330	if ($options{'o'}) {
444			print_orphans();
445			exit 0;
446			}
447			if ($options{l}) {
448			$long = 1;
449			}
450			if ($options{a}) {
451	frodo	337	if ($names_only) {
452			print_archive_names_only($options{a});
453			} else {
454			print_archives_only($options{a},$long);
455			}
456	frodo	330	exit 0;
457			}
458			if ($options{A}) {
459	frodo	337	if ($names_only) {
460			print_archive_names_only_regexp($options{A});
461			} else {
462			print_archives_only_regexp($options{A},$long);
463			}
464	frodo	330	exit 0;
465			}
466	frodo	332	if ($options{x}) {
467	frodo	337	if ($names_only) {
468			print_archive_names_except($options{x});
469			} else {
470			print_archives_except($options{x},$long);
471			}
472	frodo	332	exit 0;
473			}
474			if ($options{X}) {
475	frodo	337	if ($names_only) {
476			print_archive_names_except($options{X});
477			} else {
478			print_archives_except_regexp($options{X},$long);
479			}
480	frodo	332	exit 0;
481			}
482	frodo	337	if ($names_only) {
483			print_archive_names()
484			} else {
485			print_all();
486			}
487	frodo	330
488
489			# vim:sw=2:ft=perl:expandtab:
frodo@frodo.looijaard.name	ViewVC Help
Powered by ViewVC 1.1.26