2 # build-versions-db builds the versions mldmb database
3 # and is released under the terms of the GNU GPL version 3, or any
4 # later version, at your option. See the file README and COPYING for
6 # Copyright 2016 by Don Armstrong <don@donarmstrong.com>.
17 build-versions-db -- builds source and source maintainers file
21 build-versions-db [options] versions.idx.new versions.idx.new \
22 /srv/bugs.debian.org/versions/indices/ftp
25 --debug, -d debugging level (Default 0)
26 --help, -h display this help
27 --man, -m display manual
35 Update an existing database; the default. B<--no-update> will regenerate an
36 existing database from scratch.
40 Debug verbosity. (Default 0)
44 Display brief usage information.
54 build-versions-db versions.idx.new versions.idx.new \
55 /srv/bugs.debian.org/versions/indices/ftp \
62 use Debbugs::Versions::Dpkg;
63 use Debbugs::Config qw(:config);
65 use MLDBM qw(DB_File Storable);
68 my %options = (debug => 0,
76 'debug|d+','help|h|?','man|m');
78 pod2usage() if $options{help};
79 pod2usage({verbose=>2}) if $options{man};
81 $DEBUG = $options{debug};
87 "You must provide at least four arguments, two databases, ".
88 "a top level directory and at least one suite";
92 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
95 my $versions = shift @ARGV;
96 my $versions_time = shift @ARGV;
97 my $versions_new = $versions."_".$$."_".time;
98 my $versions_time_new = $versions_time."_".$$."_".time;
99 my $toplevel = shift @ARGV;
102 $MLDBM::DumpMeth=q(portable);
108 if ($options{update}) {
109 copy($versions,$versions_new);
110 copy($versions_time,$versions_time_new);
112 tie %db, "MLDBM", $versions_new, O_CREAT|O_RDWR, 0664
113 or die "tie $versions: $!";
114 tie %db2, "MLDBM", $versions_time_new,O_CREAT|O_RDWR, 0664
115 or die "tie $versions_time failed: $!";
117 update_versions_suites(\%db,\%db2,\@suites);
118 versions_time_cleanup(\%db2) if $options{update};
120 move($versions_new,$versions);
121 move($versions_time_new,$versions_time);
123 sub open_compressed_file {
126 my $mode = '<:encoding(UTF-8)';
128 if ($file =~ /\.gz$/) {
129 $mode = '-|:encoding(UTF-8)';
130 push @opts,'gzip','-dc';
132 if ($file =~ /\.xz$/) {
133 $mode = '-|:encoding(UTF-8)';
134 push @opts,'xz','-dc';
136 if ($file =~ /\.bz2$/) {
137 $mode = '-|:encoding(UTF-8)';
138 push @opts,'bzip2','-dc';
140 open($fh,$mode,@opts,$file);
144 # Read Package, Version, and Source fields from a Packages.gz file.
146 my ($db,$db2,$packages, $component,$arch,$dist) = @_;
147 my $PACKAGES = open_compressed_file($packages) or
148 die "Unable to open $packages for reading: $!";
150 local $/ = ''; # paragraph mode
152 print STDERR "reading packages $packages\n" if $DEBUG;
154 /^Package: (.+)/im or next;
156 /^Version: (.+)/im or next;
158 my $extra_source_only = 0;
159 if (/^Extra-Source-Only: yes/im) {
160 $extra_source_only = 1;
162 update_package_version($db,$db2,$dist,$arch,$pkg,$ver,$time) unless
168 sub update_package_version {
169 my ($db,$db2,$d,$a,$p,$v,$t) = @_;
170 # see MLDBM(3pm)/BUGS
172 # we allow multiple versions in an architecture now; this
173 # should really only happen in the case of source, however.
174 push @{$tmp->{$d}{$a}}, $v;
177 $tmp->{$d}{$a}{$v} = $time if not exists
182 sub update_versions_suites {
183 my ($db,$db2,$suites) = @_;
184 # Iterate through all Packages and Sources files.
185 for my $suite (@{$suites}) {
186 my $suitedir = "$toplevel/$suite";
188 for my $component ('main', 'main/debian-installer',
189 'contrib', 'non-free') {
190 my $componentdir = "$suitedir/$component";
191 next unless -d $componentdir;
193 opendir $COMPONENT, $componentdir or die "opendir $componentdir: $!";
195 # debian-installer is really a section rather than a component
197 (my $viscomponent = $component) =~ s[/.*][];
199 my $sources = (grep { -f $_ } glob "$suitedir/$component/source/Sources.*")[0];
200 next unless defined $sources;
201 read_packages($db,$db2,$sources, $viscomponent,'source',$suite);
203 for my $arch (readdir $COMPONENT) {
204 next unless $arch =~ s/^binary-//;
205 my $archdir = "$componentdir/binary-$arch";
207 my $packages = (grep { -f $_ } glob("$archdir/Packages.*"))[0];
208 next unless defined $packages;
209 read_packages($db,$db2,$packages, $viscomponent,$arch,$suite);
217 sub versions_time_cleanup {
220 for my $package (keys %{$db}) {
221 my $temp = $db->{$package};
222 for my $dist (keys %{$temp}) {
223 for my $arch (keys %{$temp->{$dist}}) {
224 my @versions = (sort {$temp->{$dist}{$arch}{$a} <=>
225 $temp->{$dist}{$arch}{$b}
227 keys %{$temp->{$dist}{$arch}});
228 next unless @versions > 1;
229 for my $i (0 .. ($#versions-1)) {
230 last if $temp->{$dist}{$arch}{$versions[$i+1]} >
231 ($time - $config{remove_age}*60*60*24);
232 last if keys %{$temp->{$dist}{$arch}} <= 1;
233 delete $temp->{$dist}{$arch}{$versions[$i]};
237 $db->{$package} = $temp;