2 # list-srcpkg -- maemian 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-srcpkg [-v] <output-list-file>\n";
31 print " -v verbose\n";
36 my $output_file = undef;
38 while (my $arg = shift) {
39 if ($arg =~ s,^-,,o) {
43 print STDERR "error: unknown command line argument: $arg\n";
48 print STDERR "error: too many command line arguments: $arg\n";
54 unless ($output_file) {
55 print STDERR "error: no output file specified\n";
59 # import perl libraries
60 use lib "$ENV{'MAEMIAN_ROOT'}/lib";
62 use vars qw(%source_info $SRCLIST_FORMAT); # from the above
65 # get variables out of environment
66 my $MAEMIAN_ARCHIVEDIR = $ENV{'MAEMIAN_ARCHIVEDIR'};
67 my $MAEMIAN_DIST = $ENV{'MAEMIAN_DIST'};
68 my $MAEMIAN_LAB = $ENV{'MAEMIAN_LAB'};
69 my $MAEMIAN_AREA = $ENV{'MAEMIAN_AREA'};
71 # read old list file (this command does nothing if the file does not exist)
72 read_src_list($output_file,1);
75 # map filenames to package names
76 for my $pkg (keys %source_info) {
77 $pkgfile{$source_info{$pkg}->{'file'}} = $pkg;
81 open(OUT, '>', $output_file) or fail("cannot open list file $output_file for writing: $!");
82 print OUT "$SRCLIST_FORMAT\n";
84 # parse Sources.gz to get list of packages
85 my $sources = "$MAEMIAN_ARCHIVEDIR/dists/$MAEMIAN_DIST/$MAEMIAN_AREA/source/Sources.gz";
86 print "N: Parsing $sources ...\n" if $verbose;
87 open(IN, '-|', 'zcat', $sources) or fail("Cannot open input pipe from zcat $sources: $!");
94 do { $line = <IN> } until ($line =~ m/^Directory: (.*)$/m);
96 do { $line = <IN> } until ($line =~ m/^ [0-9a-f]{32} [0-9]+ (.+\.dsc)$/m);
97 my $dsc_file = "$pkg_dir/$1";
98 do { $line = <IN> } until ($line =~ m/^\s*$/m);
102 unless (@stat = stat "$MAEMIAN_ARCHIVEDIR/$dsc_file") {
103 warn "E: general: cannot stat file $MAEMIAN_ARCHIVEDIR/$dsc_file: $!\n";
106 my $timestamp = $stat[9];
108 my ($status,$pkg,$data);
110 # was package already included in last list?
111 if (exists $pkgfile{$dsc_file}) {
113 $pkg = $pkgfile{$dsc_file};
114 $data = $source_info{$pkg};
116 # file changed since last run?
117 if ($timestamp == $data->{'timestamp'}) {
119 $status = 'unchanged';
122 delete $source_info{$pkg};
125 # new package, get info
129 if (($status eq 'new') or ($status eq 'changed')) {
130 # use eval when calling get_dsc_info, since we don't want to `die' just
131 # because of a single broken package
132 eval { $data = get_dsc_info("$MAEMIAN_ARCHIVEDIR/$dsc_file"); };
136 print "E: general: bad-source-package $dsc_file\n";
140 for my $fs (split(/\n/,$data->{'files'})) {
141 next if $fs =~ /^\s*$/o;
142 my @t = split(/\s+/o,$fs);
145 $data->{'files'} = join(',',@f);
146 $data->{'standards-version'} ||= "";
147 $pkg = $data->{'source'};
150 # check for duplicates
151 if (exists $packages{$pkg}) {
152 print "E: general: duplicate-source-package $pkg\n";
156 # write entry to output file
157 for (qw/version maintainer uploaders architecture standards-version binary files/) {
158 $data->{$_} =~ tr/;\n/_ / if $data->{$_};
163 $data->{'maintainer'},
164 $data->{'uploaders'} || '',
165 $data->{'architecture'},
166 $data->{'standards-version'},
172 printf "N: Listed %s source package %s %s\n",$status,$pkg,$data->{'version'} if $verbose;
174 # remove record from hash
175 delete $source_info{$pkg} if $status eq 'unchanged';
179 close(IN) or fail("cannot close input pipe: $!");
180 close(OUT) or fail("cannot close output pipe: $!");
183 # all packages that are still included in %source_info have disappeared from the archive...
184 for my $pkg (sort keys %source_info) {
185 print "N: Removed source package $pkg from list\n";
187 printf "N: Listed %d source packages\n",$total;
193 # indent-tabs-mode: nil
194 # cperl-indent-level: 2
196 # vim: syntax=perl sw=2 sts=2 ts=2 et shiftround