=over
+=item B<--update>
+
+Update an existing database; the default. B<--no-update> will regenerate an
+existing database from scratch.
+
=item B<--debug, -d>
Debug verbosity. (Default 0)
use vars qw($DEBUG);
use Debbugs::Versions::Dpkg;
+use Debbugs::Config qw(:config);
+use File::Copy;
use MLDBM qw(DB_File Storable);
use Fcntl;
my %options = (debug => 0,
help => 0,
man => 0,
+ update => 1,
);
GetOptions(\%options,
+ 'update!',
'debug|d+','help|h|?','man|m');
pod2usage() if $options{help};
"a top level directory and at least one suite";
}
+
pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
my $versions = shift @ARGV;
my $versions_time = shift @ARGV;
+my $versions_new = $versions."_".$$."_".time;
+my $versions_time_new = $versions_time."_".$$."_".time;
my $toplevel = shift @ARGV;
my @suites = @ARGV;
my %db;
my %db2;
-tie %db, "MLDBM", $versions, O_CREAT|O_RDWR, 0664
+if ($options{update}) {
+ copy($versions,$versions_new);
+ copy($versions_time,$versions_time_new);
+}
+tie %db, "MLDBM", $versions_new, O_CREAT|O_RDWR, 0664
or die "tie $versions: $!";
-tie %db2, "MLDBM", $versions_time,O_CREAT|O_RDWR, 0664
+tie %db2, "MLDBM", $versions_time_new,O_CREAT|O_RDWR, 0664
or die "tie $versions_time failed: $!";
+update_versions_suites(\%db,\%db2,\@suites);
+versions_time_cleanup(\%db2) if $options{update};
+
+move($versions_new,$versions);
+move($versions_time_new,$versions_time);
+
sub open_compressed_file {
my ($file) = @_;
my $fh;
# Read Package, Version, and Source fields from a Packages.gz file.
sub read_packages {
- my ($packages, $component,$arch,$dist) = @_;
- my $PACKAGES = open_compressed_file($packages)
+ my ($db,$db2,$packages, $component,$arch,$dist) = @_;
+ my $PACKAGES = open_compressed_file($packages) or
die "Unable to open $packages for reading: $!";
local $_;
local $/ = ''; # paragraph mode
if (/^Extra-Source-Only: yes/im) {
$extra_source_only = 1;
}
- update_package_version($dist,$arch,$pkg,$ver,$time) unless
+ update_package_version($db,$db2,$dist,$arch,$pkg,$ver,$time) unless
$extra_source_only;
}
}
sub update_package_version {
- my ($d,$a,$p,$v,$t) = @_;
+ my ($db,$db2,$d,$a,$p,$v,$t) = @_;
# see MLDBM(3pm)/BUGS
- my $tmp = $db{$p};
+ my $tmp = $db->{$p};
# we allow multiple versions in an architecture now; this
# should really only happen in the case of source, however.
push @{$tmp->{$d}{$a}}, $v;
- $db{$p} = $tmp;
- $tmp = $db2{$p};
+ $db->{$p} = $tmp;
+ $tmp = $db2->{$p};
$tmp->{$d}{$a}{$v} = $time if not exists
$tmp->{$d}{$a}{$v};
- $db2{$p} = $tmp;
+ $db2->{$p} = $tmp;
}
+sub update_versions_suites {
+ my ($db,$db2,$suites) = @_;
# Iterate through all Packages and Sources files.
-for my $suite (@suites) {
+for my $suite (@{$suites}) {
my $suitedir = "$toplevel/$suite";
for my $component ('main', 'main/debian-installer',
my $sources = (grep { -f $_ } glob "$suitedir/$component/source/Sources.*")[0];
next unless defined $sources;
- read_packages($sources, $viscomponent,'source',$suite);
+ read_packages($db,$db2,$sources, $viscomponent,'source',$suite);
for my $arch (readdir $COMPONENT) {
next unless $arch =~ s/^binary-//;
my $packages = (grep { -f $_ } glob("$archdir/Packages.*"))[0];
next unless defined $packages;
- read_packages($packages, $viscomponent,$arch,$suite);
+ read_packages($db,$db2,$packages, $viscomponent,$arch,$suite);
}
closedir $COMPONENT;
}
}
+}
-
+sub versions_time_cleanup {
+ my ($db) = @_;
+ my $time = time;
+ for my $package (keys %{$db}) {
+ my $temp = $db->{$package};
+ for my $dist (keys %{$temp}) {
+ for my $arch (keys %{$temp->{$dist}}) {
+ my @versions = (sort {$temp->{$dist}{$arch}{$a} <=>
+ $temp->{$dist}{$arch}{$b}
+ }
+ keys %{$temp->{$dist}{$arch}});
+ next unless @versions > 1;
+ for my $i (0 .. ($#versions-1)) {
+ last if $temp->{$dist}{$arch}{$versions[$i+1]} >
+ ($time - $config{remove_age}*60*60*24);
+ last if keys %{$temp->{$dist}{$arch}} <= 1;
+ delete $temp->{$dist}{$arch}{$versions[$i]};
+ }
+ }
+ }
+ $db->{$package} = $temp;
+ }
+}