+++ /dev/null
-#!/usr/bin/perl -w
-# list-binpkg -- lintian helper script
-
-# Copyright (C) 1998 Christian Schwarz
-#
-# 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 2 of the License, or
-# (at your option) any later version.
-#
-# This program 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, you can find it on the World Wide
-# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
-# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
-# MA 02110-1301, USA.
-
-use strict;
-
-# turn file buffering off:
-$| = 1;
-
-# parse command line options
-if ($#ARGV == -1) {
- print "list-binpkg [-v] <output-list-file>\n";
- print "options:\n";
- print " -v verbose\n";
- exit 0;
-}
-
-my $verbose = 0;
-my $output_file = undef;
-my $pkgdata = undef; # WTF?
-
-while (my $arg = shift) {
- if ($arg =~ s,^-,,o) {
- if ($arg eq 'v') {
- $verbose = 1;
- } else {
- print STDERR "error: unknown command line argument: $arg\n";
- exit 1;
- }
- } else {
- if ($output_file) {
- print STDERR "error: too many command line arguments: $arg\n";
- exit 1;
- }
- $output_file = $arg;
- }
-}
-
-unless ($output_file) {
- print STDERR "error: no output file specified\n";
- exit 1;
-}
-
-# import perl libraries
-use lib "$ENV{'LINTIAN_ROOT'}/lib";
-use Read_pkglists;
-use vars qw(%binary_info $BINLIST_FORMAT); # from the above
-use Pipeline;
-use Util;
-
-# get variables out of environment
-my $LINTIAN_ARCHIVEDIR = $ENV{'LINTIAN_ARCHIVEDIR'};
-my $LINTIAN_DIST = $ENV{'LINTIAN_DIST'};
-my $LINTIAN_ARCH = $ENV{'LINTIAN_ARCH'};
-my $LINTIAN_SECTION = $ENV{'LINTIAN_SECTION'};
-my $LINTIAN_LAB = $ENV{'LINTIAN_LAB'};
-
-# read old list file (this command does nothing if the file does not exist)
-read_bin_list($output_file,1);
-
-my %pkgfile;
-# map filenames to package names
-for my $pkg (keys %binary_info) {
- $pkgfile{$binary_info{$pkg}->{'file'}} = $pkg;
-}
-
-# open output file
-open(OUT, '>', $output_file)
- or fail("cannot open list file $output_file for writing: $!");
-print OUT "$BINLIST_FORMAT\n";
-
-# parse Packages file to get list of packages
-my $packages = "$LINTIAN_ARCHIVEDIR/dists/$LINTIAN_DIST/$LINTIAN_SECTION/".
- "binary-$LINTIAN_ARCH/Packages";
-if (-e $packages) {
- print "N: Parsing $packages ...\n" if $verbose;
- open(IN, '<', $packages) or fail("cannot open Packages file $packages: $!");
-} elsif (-e "$packages.gz") {
- print "N: Parsing $packages.gz ...\n" if $verbose;
- open (IN, '-|', 'gzip', '-dc', "$packages.gz")
- or fail("cannot open Packages file $packages.gz: $!");
-} else {
- fail("No packages file $packages");
-}
-
-my $line;
-my %packages;
-my $total = 0;
-
-while (!eof(IN)) {
- do { $line = <IN> } until ($line =~ m/^Architecture: (.*)$/m);
- my $arch = $1;
- do { $line = <IN> } until ($line =~ m/^Filename: (.*)$/m);
- my $deb_file = $1;
- do { $line = <IN> } until ($line =~ m/^\s*$/m);
-
- my @stat;
- # get timestamp...
- unless (@stat = stat "$LINTIAN_ARCHIVEDIR/$deb_file") {
- print "E: general: cannot stat $LINTIAN_ARCHIVEDIR/$deb_file\n";
- next;
- }
- my $timestamp = $stat[9];
- my ($status, $pkg, $data);
-
- # was package already included in last list?
- if (exists $pkgfile{$deb_file}) {
- # yes!
- $pkg = $pkgfile{$deb_file};
- $data = $binary_info{$pkg};
-
- # file changed since last run?
- if ($timestamp == $data->{'timestamp'}) {
- # no.
- $status = 'unchanged';
- } else {
- $status = 'changed';
- delete $binary_info{$pkg};
- }
- } else {
- # new package, get info
- $status = 'new';
- }
-
- if (($status eq 'new') or ($status eq 'changed')) {
- if (defined $pkgdata) {
- # avoid collecting the info twice
- $data = $pkgdata;
- } else {
- $data = &safe_get_deb_info($deb_file);
- }
- next if not defined $data;
- $pkg = $data->{'package'};
- }
-
- # check for duplicates
- if (exists $packages{$pkg}) {
- print "E: general: duplicate-binary-package $pkg\n";
- next;
- }
-
- # write entry to output file
- print OUT join(';',
- $pkg,
- $data->{'version'},
- $data->{'source'},
- $deb_file,
- $timestamp,
- ),"\n";
- printf "N: Listed %s binary package %s %s\n",$status,$pkg,$data->{'version'} if $verbose;
-
- # remove record from hash
- delete $binary_info{$pkg} if $status eq 'unchanged';
- $packages{$pkg} = 1;
- $total++;
-}
-close(IN) or fail("cannot close input pipe: $!");
-close(OUT) or fail("cannot close output pipe: $!");
-
-if ($verbose) {
- # all packages that are still included in %binary_info have disappeared from the archive...
- for my $pkg (sort keys %binary_info) {
- print "N: Removed binary package $pkg from list\n";
- }
- printf "N: Listed %d binary packages\n",$total;
-}
-
-exit 0;
-
-sub safe_get_deb_info {
- # use eval when calling get_deb_info, since we don't want to `die' just
- # because of a single broken package
- my $data;
- eval { $data = get_deb_info("$LINTIAN_ARCHIVEDIR/$_[0]"); };
- if ($@) {
- # error!
- print STDERR "$@\n";
- print "E: general: bad-binary-package $_[0]\n";
- return undef;
- }
- $data->{'source'} or ($data->{'source'} = $data->{'package'});
- return $data;
-}
projects / maemian / blobdiff