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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 333 - (hide annotations)
Tue Jun 17 09:54:05 2014 UTC (10 years, 5 months ago) by frodo
File size: 11506 byte(s)
(Frodo) Debianize the package

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     my $version = '1.0';
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    
58     # Read a package list file and save it into global variable %package_lists.
59     # Parameter 1: $file: File name (within /var/lib/apt/lists) of the package list
60     # Returns: Nothing
61     # Side effects: Fills in global variabale $package_lists{$file}
62     sub read_package_list
63     {
64     my ($file) = @_;
65     my ($entry,$package);
66     open(FILE, '/var/lib/apt/lists/'.$file) or die "Can't open $file: $!";
67     while (<FILE>) {
68     chomp;
69     ($package) = /^Package:\s*(.*)$/ if /^Package:/;
70     ($entry->{'architecture'}) = /^Architecture:\s*(.*)$/ if /^Architecture:/;
71     ($entry->{'version'}) = /^Version:\s*(.*)$/ if /^Version:/;
72     ($entry->{'multiarch'}) = /^Multi-Arch:\s*(.*)$/ if /^Multi-Arch:/;
73     if (/^\s*$/ and defined($package)) {
74     $entry->{'package'} = $package;
75     push (@{$package_lists{$file}->{$package}}, $entry);
76     undef($entry);
77     undef($package);
78     }
79     }
80     if (defined($entry)) {
81     push (@{$package_lists{$file}->{$package}}, $entry);
82     }
83     close(FILE);
84     }
85    
86     # Read all package list files and save them into global variable %package_lists.
87     # Parameters: None
88     # Returns: Nothing
89     # Side effects: Fills in global variabale $package_lists
90     sub read_all_package_lists
91     {
92     opendir(DIR, '/var/lib/apt/lists') or die "Can't opendir: $!";
93     while (defined(my $file = readdir(DIR))) {
94     read_package_list($file) if $file =~ /_Packages$/
95     }
96     closedir(DIR);
97     }
98    
99     # Read all installed packages and save them into global variable %installed_packages
100     # Parameters: None
101     # Returns: Nothing
102     # Side effects: Fills in global variabale $package_lists
103     sub read_installed_packages
104     {
105     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: $!";
106     while (<FILE>) {
107     chomp;
108     my ($status, $package, $binpackage,$version,$architecture) = split "\t";
109     push @{$installed_packages{$package}},{ 'status' => $status,
110     'binpackage' => $binpackage,
111     'version' => $version,
112     'package' => $package,
113     'architecture' => $architecture };
114     }
115     close FILE;
116     }
117    
118     # Try to locate a package in the archive lists, matching name, architecture
119     # and version.
120     # Parameters: $package_data: reference to a hash containing the package data
121     # Returns: An array of lists in which this package is available
122     sub find_package
123     {
124     my ($package_data) = @_;
125     my @lists_found = ();
126     foreach my $listname (keys %package_lists) {
127     if (exists ($package_lists{$listname}->{$package_data->{'package'}})) {
128     foreach my $entry (@{$package_lists{$listname}->{$package_data->{'package'}}}) {
129     if ($entry->{'architecture'} eq $package_data->{'architecture'} and $entry->{'version'} eq $package_data->{'version'}) {
130     push @lists_found,$listname;
131     last;
132     }
133     }
134     }
135     }
136     return \@lists_found;
137     }
138    
139     # Determine for all installed packages in which archives they are found
140     # Parameters: None
141     # Returns: Nothing
142     # Side effects: Fills in global variabale $installed_packages
143     sub find_all_packages
144     {
145     foreach my $package_name (keys %installed_packages) {
146     foreach my $entry (@{$installed_packages{$package_name}}) {
147     $entry->{'lists'} = find_package($entry);
148     }
149     }
150     }
151    
152     # Fill all global variables
153     sub init
154     {
155     read_installed_packages();
156     read_all_package_lists();
157     find_all_packages();
158     }
159    
160    
161     ###############
162     # OUTPUT DATA #
163     ###############
164    
165 frodo 332 # Go through the list of all packages and call a subroutine on each installed
166     # package.
167     # Parameter 1: $sub: Reference to the subroutine to call
168     # Each call gets two parameters: the entry and $long
169     # Parameter 2..: @params: All other parameters
170     # Returns: Nothing
171     # Side effects: Generates output on STDOUT
172     sub iterate_through_packages {
173     my ($sub, @params) = @_;
174     foreach my $package_name (sort keys %installed_packages) {
175     foreach my $entry (@{$installed_packages{$package_name}}) {
176 frodo 330 if ($entry->{status} eq 'install ok installed') {
177 frodo 332 &$sub($entry, @params)
178 frodo 330 }
179     }
180     }
181     }
182    
183 frodo 332 # Print an entry, either with or without its archives
184     # Parameter 1: $entry: a hash reference containing keys package, architecture
185     # and version (as well as lists if $long is true)
186     # Parameter 2: $long: whether to print the archives too
187     # Returns: nothing
188     # Side effects: Generates output on STDOUT
189     sub print_item
190 frodo 330 {
191 frodo 332 my ($entry, $long) = @_;
192     if ($long) {
193     print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n";
194     } else {
195     print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n";
196 frodo 330 }
197     }
198    
199 frodo 332 # Print all packages, including archives
200     sub print_all
201     {
202     iterate_through_packages(\&print_item, 1);
203     }
204    
205    
206     # Print only those packages that have no archive associated with them
207     sub print_orphans
208     {
209     iterate_through_packages(\&print_orphans_item);
210     }
211    
212     # Callback: check whether an entry is an orphan and if so print it
213     sub print_orphans_item
214     {
215     my ($entry) = @_;
216     if (! @{$entry->{lists}}) {
217     print_item($entry, 0);
218     }
219     }
220    
221     # Print those packages which are only in the specified archives
222 frodo 330 sub print_archives_only
223     {
224     my ($archives,$long) = @_;
225     my %archives;
226     foreach my $archive (split (/,/,$archives)) {
227     $archives{$archive} = 1;
228     }
229 frodo 332 iterate_through_packages(\&print_archives_only_item, \%archives, $long);
230     }
231    
232     # Callback: print an entry if it is only in the specified archives
233     sub print_archives_only_item
234     {
235     my ($entry,$archives, $long) = @_;
236     my $valid = 1;
237     foreach my $list (@{$entry->{lists}}) {
238     if (! exists($archives->{$list})) {
239     $valid = 0;
240     last;
241 frodo 330 }
242     }
243 frodo 332 if ($valid and @{$entry->{lists}}) {
244     print_item($entry, $long)
245     }
246 frodo 330 }
247    
248 frodo 332 # Print those packages which are only in the archives specified through a
249     # regular expression
250 frodo 330 sub print_archives_only_regexp
251     {
252     my ($archives_regexp,$long) = @_;
253 frodo 332 iterate_through_packages(\&print_archives_only_regexp_item, $archives_regexp, $long);
254     }
255    
256     # Callback: print an entry if it is only in the archives specified through a
257     # regular expression
258     sub print_archives_only_regexp_item
259     {
260     my ($entry, $archives_regexp, $long) = @_;
261     my $valid = 1;
262     foreach my $list (@{$entry->{lists}}) {
263     if (! ($list =~ /$archives_regexp/)) {
264     $valid = 0;
265     last;
266 frodo 330 }
267     }
268 frodo 332 if ($valid and @{$entry->{lists}}) {
269     print_item($entry, $long)
270     }
271 frodo 330 }
272    
273 frodo 332 # Print those packages which are not in the specified archives
274     sub print_archives_except
275     {
276     my ($archives,$long) = @_;
277     my %archives;
278     foreach my $archive (split (/,/,$archives)) {
279     $archives{$archive} = 1;
280     }
281     iterate_through_packages(\&print_archives_except_item, \%archives, $long);
282     }
283 frodo 330
284 frodo 332 # Callback: print an entry if it is not in the specified archives
285     sub print_archives_except_item
286     {
287     my ($entry,$archives, $long) = @_;
288     my $valid = 1;
289     foreach my $list (@{$entry->{lists}}) {
290     if (exists($archives->{$list})) {
291     $valid = 0;
292     last;
293     }
294     }
295     if ($valid and @{$entry->{lists}}) {
296     print_item($entry, $long)
297     }
298     }
299    
300     # Print those packages which are not in the archives specified through a
301     # regular expression
302     sub print_archives_except_regexp
303     {
304     my ($archives_regexp,$long) = @_;
305     iterate_through_packages(\&print_archives_except_regexp_item, $archives_regexp, $long);
306     }
307    
308     # Callback: print an entry if it is not in the archives specified through a
309     # regular expression
310     sub print_archives_except_regexp_item
311     {
312     my ($entry, $archives_regexp, $long) = @_;
313     my $valid = 1;
314     foreach my $list (@{$entry->{lists}}) {
315     if ($list =~ /$archives_regexp/) {
316     $valid = 0;
317     last;
318     }
319     }
320     if ($valid and @{$entry->{lists}}) {
321     print_item($entry, $long)
322     }
323     }
324    
325 frodo 330 #########################
326     # COMMAND LINE HANDLING #
327     #########################
328    
329     sub print_help
330     {
331     print STDERR "$execname [OPTION]\n";
332     print STDERR " -h: help text and exit\n";
333     print STDERR " -V: print version and exit\n";
334     print STDERR " -o: orphans: packages that are not in any archive\n";
335     print STDERR " -a ARCHS: archives: list all packages that are only in one of the listed\n";
336     print STDERR " archives (seperated by commas)\n";
337     print STDERR " -A ARCHREGEXP: archives: list all packages that are only in archives\n";
338     print STDERR " that match the regular expression\n";
339 frodo 332 print STDERR " -x ARCHS: except: list all packages that are not in one of the listed\n";
340     print STDERR " archives (seperated by commas)\n";
341     print STDERR " -X ARCHREGEXP: except: list all packages that are not in archives\n";
342     print STDERR " that match the regular expression\n";
343 frodo 330 print STDERR " -l: long: print archives too\n";
344    
345     print STDERR "Default: print all packages and sources\n";
346     }
347    
348     sub print_version
349     {
350     print STDERR "$execname $version\n";
351     }
352    
353     sub HELP_MESSAGE
354     {
355     print_help();
356     exit 0;
357     }
358    
359     $Getopt::Std::STANDARD_HELP_VERSION=1;
360    
361     our $VERSION=$version;
362     my %options;
363 frodo 332 if (! getopts('hVola:A:x:X:',\%options))
364 frodo 330 {
365     print_help();
366     exit 1;
367     }
368     my $long=0;
369     if ($options{'h'}) {
370     print_help();
371     exit 0;
372     }
373     if ($options{'V'}) {
374     print_version();
375     exit 0;
376     }
377     init();
378     if ($options{'o'}) {
379     print_orphans();
380     exit 0;
381     }
382     if ($options{l}) {
383     $long = 1;
384     }
385     if ($options{a}) {
386     print_archives_only($options{a},$long);
387     exit 0;
388     }
389     if ($options{A}) {
390     print_archives_only_regexp($options{A},$long);
391     exit 0;
392     }
393 frodo 332 if ($options{x}) {
394     print_archives_except($options{x},$long);
395     exit 0;
396     }
397     if ($options{X}) {
398     print_archives_except_regexp($options{X},$long);
399     exit 0;
400     }
401 frodo 330 print_all;
402    
403    
404     # vim:sw=2:ft=perl:expandtab:

Properties

Name Value
svn:executable *

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