2 # list-udebpkg -- maemian helper script
4 # Copyright (C) 1998 Christian Schwarz
5 # Copyright (C) 2004 Frank Lichtenheld
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.
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.
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,
25 # turn file buffering off:
28 # parse command line options
30 print "list-udebpkg [-v] <output-list-file>\n";
32 print " -v verbose\n";
37 my $output_file = undef;
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{'MAEMIAN_ROOT'}/lib";
64 use vars qw(%udeb_info $UDEBLIST_FORMAT); # from the above
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'};
74 # read old list file (this command does nothing if the file does not exist)
75 read_udeb_list($output_file,1);
78 # map filenames to package names
79 for my $pkg (keys %udeb_info) {
80 $pkgfile{$udeb_info{$pkg}->{'file'}} = $pkg;
84 open(OUT, '>', $output_file)
85 or fail("cannot open list file $output_file for writing: $!");
86 print OUT "$UDEBLIST_FORMAT\n";
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";
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: $!");
99 fail("No packages file $packages");
107 do { $line = <IN> } until ($line =~ m/^Architecture: (.*)$/m);
109 do { $line = <IN> } until ($line =~ m/^Filename: (.*)$/m);
111 do { $line = <IN> } until ($line =~ m/^\s*$/m);
115 unless (@stat = stat "$MAEMIAN_ARCHIVEDIR/$deb_file") {
116 print "E: general: cannot stat $MAEMIAN_ARCHIVEDIR/$deb_file\n";
119 my $timestamp = $stat[9];
120 my ($status, $pkg, $data);
122 # was package already included in last list?
123 if (exists $pkgfile{$deb_file}) {
125 $pkg = $pkgfile{$deb_file};
126 $data = $udeb_info{$pkg};
128 # file changed since last run?
129 if ($timestamp == $data->{'timestamp'}) {
131 $status = 'unchanged';
134 delete $udeb_info{$pkg};
137 # new package, get info
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'};
147 # check for duplicates
148 if (exists $packages{$pkg}) {
149 print "E: general: duplicate-udeb-package $pkg\n";
153 unless (exists $data->{'source-version'}) {
154 if ($data->{'source'} =~ /^([-+\.\w]+)\s+\((.+)\)$/) {
155 $data->{'source'} = $1;
156 $data->{'source-version'} = $2;
158 $data->{'source-version'} = $data->{'version'};
162 # write entry to output file
167 $data->{'source-version'},
171 printf "N: Listed %s udeb package %s %s\n",$status,$pkg,$data->{'version'} if $verbose;
173 # remove record from hash
174 delete $udeb_info{$pkg} if $status eq 'unchanged';
178 close(IN) or fail("cannot close input pipe: $!");
179 close(OUT) or fail("cannot close output pipe: $!");
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";
186 printf "N: Listed %d udeb packages\n",$total;
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
195 eval { $data = get_deb_info("$MAEMIAN_ARCHIVEDIR/$_[0]"); };
199 print "E: general: bad-udeb-package $_[0]\n";
202 $data->{'source'} or ($data->{'source'} = $data->{'package'});