2 # list-binpkg -- lintian helper script
4 # Copyright (C) 1998 Christian Schwarz
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 2 of the License, or
9 # (at your option) any later version.
11 # This program 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.
16 # You should have received a copy of the GNU General Public License
17 # along with this program. If not, you can find it on the World Wide
18 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
19 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
24 # turn file buffering off:
27 # parse command line options
29 print "list-binpkg [-v] <output-list-file>\n";
31 print " -v verbose\n";
36 my $output_file = undef;
37 my $pkgdata = undef; # WTF?
39 while (my $arg = shift) {
40 if ($arg =~ s,^-,,o) {
44 print STDERR "error: unknown command line argument: $arg\n";
49 print STDERR "error: too many command line arguments: $arg\n";
56 unless ($output_file) {
57 print STDERR "error: no output file specified\n";
61 # import perl libraries
62 use lib "$ENV{'LINTIAN_ROOT'}/lib";
64 use vars qw(%binary_info $BINLIST_FORMAT); # from the above
68 # get variables out of environment
69 my $LINTIAN_ARCHIVEDIR = $ENV{'LINTIAN_ARCHIVEDIR'};
70 my $LINTIAN_DIST = $ENV{'LINTIAN_DIST'};
71 my $LINTIAN_ARCH = $ENV{'LINTIAN_ARCH'};
72 my $LINTIAN_SECTION = $ENV{'LINTIAN_SECTION'};
73 my $LINTIAN_LAB = $ENV{'LINTIAN_LAB'};
75 # read old list file (this command does nothing if the file does not exist)
76 read_bin_list($output_file,1);
79 # map filenames to package names
80 for my $pkg (keys %binary_info) {
81 $pkgfile{$binary_info{$pkg}->{'file'}} = $pkg;
85 open(OUT, '>', $output_file)
86 or fail("cannot open list file $output_file for writing: $!");
87 print OUT "$BINLIST_FORMAT\n";
89 # parse Packages file to get list of packages
90 my $packages = "$LINTIAN_ARCHIVEDIR/dists/$LINTIAN_DIST/$LINTIAN_SECTION/".
91 "binary-$LINTIAN_ARCH/Packages";
93 print "N: Parsing $packages ...\n" if $verbose;
94 open(IN, '<', $packages) or fail("cannot open Packages file $packages: $!");
95 } elsif (-e "$packages.gz") {
96 print "N: Parsing $packages.gz ...\n" if $verbose;
97 open (IN, '-|', 'gzip', '-dc', "$packages.gz")
98 or fail("cannot open Packages file $packages.gz: $!");
100 fail("No packages file $packages");
108 do { $line = <IN> } until ($line =~ m/^Architecture: (.*)$/m);
110 do { $line = <IN> } until ($line =~ m/^Filename: (.*)$/m);
112 do { $line = <IN> } until ($line =~ m/^\s*$/m);
116 unless (@stat = stat "$LINTIAN_ARCHIVEDIR/$deb_file") {
117 print "E: general: cannot stat $LINTIAN_ARCHIVEDIR/$deb_file\n";
120 my $timestamp = $stat[9];
121 my ($status, $pkg, $data);
123 # was package already included in last list?
124 if (exists $pkgfile{$deb_file}) {
126 $pkg = $pkgfile{$deb_file};
127 $data = $binary_info{$pkg};
129 # file changed since last run?
130 if ($timestamp == $data->{'timestamp'}) {
132 $status = 'unchanged';
135 delete $binary_info{$pkg};
138 # new package, get info
142 if (($status eq 'new') or ($status eq 'changed')) {
143 if (defined $pkgdata) {
144 # avoid collecting the info twice
147 $data = &safe_get_deb_info($deb_file);
149 next if not defined $data;
150 $pkg = $data->{'package'};
153 # check for duplicates
154 if (exists $packages{$pkg}) {
155 print "E: general: duplicate-binary-package $pkg\n";
159 # write entry to output file
167 printf "N: Listed %s binary package %s %s\n",$status,$pkg,$data->{'version'} if $verbose;
169 # remove record from hash
170 delete $binary_info{$pkg} if $status eq 'unchanged';
174 close(IN) or fail("cannot close input pipe: $!");
175 close(OUT) or fail("cannot close output pipe: $!");
178 # all packages that are still included in %binary_info have disappeared from the archive...
179 for my $pkg (sort keys %binary_info) {
180 print "N: Removed binary package $pkg from list\n";
182 printf "N: Listed %d binary packages\n",$total;
187 sub safe_get_deb_info {
188 # use eval when calling get_deb_info, since we don't want to `die' just
189 # because of a single broken package
191 eval { $data = get_deb_info("$LINTIAN_ARCHIVEDIR/$_[0]"); };
195 print "E: general: bad-binary-package $_[0]\n";
198 $data->{'source'} or ($data->{'source'} = $data->{'package'});