vcs.maemo.org Git - maemian/blob - unpack/list-udebpkg

   1 #!/usr/bin/perl -w
   2 # list-udebpkg -- maemian helper script
   3
   4 # Copyright (C) 1998 Christian Schwarz
   5 # Copyright (C) 2004 Frank Lichtenheld
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 2 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, you can find it on the World Wide
  19 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  20 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  21 # MA 02110-1301, USA.
  22
  23 use strict;
  24
  25 # turn file buffering off:
  26 $| = 1;
  27
  28 # parse command line options
  29 if ($#ARGV == -1) {
  30     print "list-udebpkg [-v] <output-list-file>\n";
  31     print "options:\n";
  32     print "   -v  verbose\n";
  33     exit 0;
  34 }
  35
  36 my $verbose = 0;
  37 my $output_file = undef;
  38
  39 while (my $arg = shift) {
  40     if ($arg =~ s,^-,,o) {
  41         if ($arg eq 'v') {
  42             $verbose = 1;
  43         } else {
  44             print STDERR "error: unknown command line argument: $arg\n";
  45             exit 1;
  46         }
  47     } else {
  48         if ($output_file) {
  49             print STDERR "error: too many command line arguments: $arg\n";
  50             exit 1;
  51         }
  52         $output_file = $arg;
  53     }
  54 }
  55
  56 unless ($output_file) {
  57     print STDERR "error: no output file specified\n";
  58     exit 1;
  59 }
  60
  61 # import perl libraries
  62 use lib "$ENV{'MAEMIAN_ROOT'}/lib";
  63 use Read_pkglists;
  64 use vars qw(%udeb_info $UDEBLIST_FORMAT); # from the above
  65 use Util;
  66
  67 # get variables out of environment
  68 my $MAEMIAN_ARCHIVEDIR = $ENV{'MAEMIAN_ARCHIVEDIR'};
  69 my $MAEMIAN_DIST = $ENV{'MAEMIAN_DIST'};
  70 my $MAEMIAN_ARCH = $ENV{'MAEMIAN_ARCH'};
  71 my $MAEMIAN_AREA = $ENV{'MAEMIAN_AREA'};
  72 my $MAEMIAN_LAB = $ENV{'MAEMIAN_LAB'};
  73
  74 # read old list file (this command does nothing if the file does not exist)
  75 read_udeb_list($output_file,1);
  76
  77 my %pkgfile;
  78 # map filenames to package names
  79 for my $pkg (keys %udeb_info) {
  80     $pkgfile{$udeb_info{$pkg}->{'file'}} = $pkg;
  81 }
  82
  83 # open output file
  84 open(OUT, '>', $output_file)
  85     or fail("cannot open list file $output_file for writing: $!");
  86 print OUT "$UDEBLIST_FORMAT\n";
  87
  88 # parse Packages file to get list of packages
  89 my $packages = "$MAEMIAN_ARCHIVEDIR/dists/$MAEMIAN_DIST/$MAEMIAN_AREA/".
  90                "debian-installer/binary-$MAEMIAN_ARCH/Packages";
  91 if (-e $packages) {
  92     print "N: Parsing $packages ...\n" if $verbose;
  93     open(IN, '<', $packages) or fail("cannot open Packages file $packages: $!");
  94 } elsif (-e "$packages.gz") {
  95     print "N: Parsing $packages.gz ...\n" if $verbose;
  96     open(IN, '-|', 'gzip', '-dc', "$packages.gz")
  97         or fail("cannot open Packages file $packages.gz: $!");
  98 } else {
  99     fail("No packages file $packages");
 100 }
 101
 102 my $line;
 103 my %packages;
 104 my $total = 0;
 105
 106 while (!eof(IN)) {
 107     do { $line = <IN> } until ($line =~ m/^Architecture: (.*)$/m);
 108     my $arch = $1;
 109     do { $line = <IN> } until ($line =~ m/^Filename: (.*)$/m);
 110     my $deb_file = $1;
 111     do { $line = <IN> } until ($line =~ m/^\s*$/m);
 112
 113     my @stat;
 114     # get timestamp...
 115     unless (@stat = stat "$MAEMIAN_ARCHIVEDIR/$deb_file") {
 116         print "E: general: cannot stat $MAEMIAN_ARCHIVEDIR/$deb_file\n";
 117         next;
 118     }
 119     my $timestamp = $stat[9];
 120     my ($status, $pkg, $data);
 121
 122     # was package already included in last list?
 123     if (exists $pkgfile{$deb_file}) {
 124         # yes!
 125         $pkg = $pkgfile{$deb_file};
 126         $data = $udeb_info{$pkg};
 127
 128         # file changed since last run?
 129         if ($timestamp == $data->{'timestamp'}) {
 130             # no.
 131             $status = 'unchanged';
 132         } else {
 133             $status = 'changed';
 134             delete $udeb_info{$pkg};
 135         }
 136     } else {
 137         # new package, get info
 138         $status = 'new';
 139     }
 140
 141     if (($status eq 'new') or ($status eq 'changed')) {
 142         $data = &safe_get_deb_info($deb_file);
 143         next if not defined $data;
 144         $pkg = $data->{'package'};
 145     }
 146
 147     # check for duplicates
 148     if (exists $packages{$pkg}) {
 149         print "E: general: duplicate-udeb-package $pkg\n";
 150         next;
 151     }
 152
 153     unless (exists $data->{'source-version'}) {
 154         if ($data->{'source'} =~ /^([-+\.\w]+)\s+\((.+)\)$/) {
 155             $data->{'source'} = $1;
 156             $data->{'source-version'} = $2;
 157         } else {
 158             $data->{'source-version'} = $data->{'version'};
 159         }
 160     }
 161
 162     # write entry to output file
 163     print OUT join(';',
 164                    $pkg,
 165                    $data->{'version'},
 166                    $data->{'source'},
 167                    $data->{'source-version'},
 168                    $deb_file,
 169                    $timestamp,
 170                    ),"\n";
 171     printf "N: Listed %s udeb package %s %s\n",$status,$pkg,$data->{'version'} if $verbose;
 172
 173     # remove record from hash
 174     delete $udeb_info{$pkg} if $status eq 'unchanged';
 175     $packages{$pkg} = 1;
 176     $total++;
 177 }
 178 close(IN) or fail("cannot close input pipe: $!");
 179 close(OUT) or fail("cannot close output pipe: $!");
 180
 181 if ($verbose) {
 182     # all packages that are still included in %udeb_info have disappeared from the archive...
 183     for my $pkg (sort keys %udeb_info) {
 184         print "N: Removed udeb package $pkg from list\n";
 185     }
 186     printf "N: Listed %d udeb packages\n",$total;
 187 }
 188
 189 exit 0;
 190
 191 sub safe_get_deb_info {
 192     # use eval when calling get_deb_info, since we don't want to `die' just
 193     # because of a single broken package
 194     my $data;
 195     eval { $data = get_deb_info("$MAEMIAN_ARCHIVEDIR/$_[0]"); };
 196     if ($@) {
 197         # error!
 198         print STDERR "$@\n";
 199         print "E: general: bad-udeb-package $_[0]\n";
 200         return undef;
 201     }
 202     $data->{'source'} or ($data->{'source'} = $data->{'package'});
 203     return $data;
 204 }