/[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 333 - (show 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 #!/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
22
23 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 # 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 if ($entry->{status} eq 'install ok installed') {
177 &$sub($entry, @params)
178 }
179 }
180 }
181 }
182
183 # 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 {
191 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 }
197 }
198
199 # 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 sub print_archives_only
223 {
224 my ($archives,$long) = @_;
225 my %archives;
226 foreach my $archive (split (/,/,$archives)) {
227 $archives{$archive} = 1;
228 }
229 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 }
242 }
243 if ($valid and @{$entry->{lists}}) {
244 print_item($entry, $long)
245 }
246 }
247
248 # Print those packages which are only in the archives specified through a
249 # regular expression
250 sub print_archives_only_regexp
251 {
252 my ($archives_regexp,$long) = @_;
253 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 }
267 }
268 if ($valid and @{$entry->{lists}}) {
269 print_item($entry, $long)
270 }
271 }
272
273 # 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
284 # 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 #########################
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 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 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 if (! getopts('hVola:A:x:X:',\%options))
364 {
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 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 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