examples/debian/versions/build-versions-db

   1 #!/usr/bin/perl
   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
   5 # more information.
   6 # Copyright 2016 by Don Armstrong <don@donarmstrong.com>.
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 build-versions-db -- builds source and source maintainers file
  18
  19 =head1 SYNOPSIS
  20
  21     build-versions-db [options] versions.idx.new versions.idx.new \
  22            /srv/bugs.debian.org/versions/indices/ftp
  23
  24  Options:
  25    --debug, -d debugging level (Default 0)
  26    --help, -h display this help
  27    --man, -m display manual
  28
  29 =head1 OPTIONS
  30
  31 =over
  32
  33 =item B<--update>
  34
  35 Update an existing database; the default. B<--no-update> will regenerate an
  36 existing database from scratch.
  37
  38 =item B<--debug, -d>
  39
  40 Debug verbosity. (Default 0)
  41
  42 =item B<--help, -h>
  43
  44 Display brief usage information.
  45
  46 =item B<--man, -m>
  47
  48 Display this manual.
  49
  50 =back
  51
  52 =head1 EXAMPLES
  53
  54      build-versions-db versions.idx.new versions.idx.new \
  55            /srv/bugs.debian.org/versions/indices/ftp \
  56            stable
  57
  58 =cut
  59
  60
  61 use vars qw($DEBUG);
  62 use Debbugs::Versions::Dpkg;
  63 use Debbugs::Config qw(:config);
  64 use File::Copy;
  65 use MLDBM qw(DB_File Storable);
  66 use Fcntl;
  67
  68 my %options = (debug           => 0,
  69                help            => 0,
  70                man             => 0,
  71                update          => 1,
  72               );
  73
  74 GetOptions(\%options,
  75            'update!',
  76            'debug|d+','help|h|?','man|m');
  77
  78 pod2usage() if $options{help};
  79 pod2usage({verbose=>2}) if $options{man};
  80
  81 $DEBUG = $options{debug};
  82
  83 my @USAGE_ERRORS;
  84
  85 if (not @ARGV >= 4) {
  86     push @USAGE_ERRORS,
  87         "You must provide at least four arguments, two databases, ".
  88         "a top level directory and at least one suite";
  89 }
  90
  91
  92 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  93
  94
  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;
 100 my @suites = @ARGV;
 101
 102 $MLDBM::DumpMeth=q(portable);
 103
 104 my $time = time;
 105
 106 my %db;
 107 my %db2;
 108 if ($options{update}) {
 109     copy($versions,$versions_new);
 110     copy($versions_time,$versions_time_new);
 111 }
 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: $!";
 116
 117 update_versions_suites(\%db,\%db2,\@suites);
 118 versions_time_cleanup(\%db2) if $options{update};
 119
 120 move($versions_new,$versions);
 121 move($versions_time_new,$versions_time);
 122
 123 sub open_compressed_file {
 124     my ($file) = @_;
 125     my $fh;
 126     my $mode = '<:encoding(UTF-8)';
 127     my @opts;
 128     if ($file =~ /\.gz$/) {
 129         $mode = '-|:encoding(UTF-8)';
 130         push @opts,'gzip','-dc';
 131     }
 132     if ($file =~ /^\.xz$/) {
 133         $mode = '-|:encoding(UTF-8)';
 134         push @opts,'xz','-dc';
 135     }
 136     if ($file =~ /^\.bz2$/) {
 137         $mode = '-|:encoding(UTF-8)';
 138         push @opts,'bzip2','-dc';
 139     }
 140     open($fh,$mode,@opts,$file);
 141     return $fh;
 142 }
 143
 144 # Read Package, Version, and Source fields from a Packages.gz file.
 145 sub read_packages {
 146     my ($db,$db2,$packages, $component,$arch,$dist) = @_;
 147     my $PACKAGES = open_compressed_file($packages) or
 148         die "Unable to open $packages for reading: $!";
 149     local $_;
 150     local $/ = '';      # paragraph mode
 151
 152     print STDERR "reading packages $packages\n" if $DEBUG;
 153     for (<$PACKAGES>) {
 154         /^Package: (.+)/im or next;
 155         my $pkg = $1;
 156         /^Version: (.+)/im or next;
 157         my $ver = $1;
 158         my $extra_source_only = 0;
 159         if (/^Extra-Source-Only: yes/im) {
 160             $extra_source_only = 1;
 161         }
 162         update_package_version($db,$db2,$dist,$arch,$pkg,$ver,$time) unless
 163             $extra_source_only;
 164     }
 165 }
 166
 167
 168 sub update_package_version {
 169     my ($db,$db2,$d,$a,$p,$v,$t) = @_;
 170     # see MLDBM(3pm)/BUGS
 171     my $tmp = $db->{$p};
 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;
 175     $db->{$p} = $tmp;
 176     $tmp = $db2->{$p};
 177     $tmp->{$d}{$a}{$v} = $time if not exists
 178         $tmp->{$d}{$a}{$v};
 179     $db2->{$p} = $tmp;
 180 }
 181
 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";
 187
 188     for my $component ('main', 'main/debian-installer',
 189                        'contrib', 'non-free') {
 190         my $componentdir = "$suitedir/$component";
 191         next unless -d $componentdir;
 192         my $COMPONENT;
 193         opendir $COMPONENT, $componentdir or die "opendir $componentdir: $!";
 194
 195         # debian-installer is really a section rather than a component
 196         # (ugh).
 197         (my $viscomponent = $component) =~ s[/.*][];
 198
 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);
 202
 203         for my $arch (readdir $COMPONENT) {
 204             next unless $arch =~ s/^binary-//;
 205             my $archdir = "$componentdir/binary-$arch";
 206
 207             my $packages = (grep { -f $_ } glob("$archdir/Packages.*"))[0];
 208             next unless defined $packages;
 209             read_packages($db,$db2,$packages, $viscomponent,$arch,$suite);
 210         }
 211
 212         closedir $COMPONENT;
 213     }
 214 }
 215 }
 216
 217 sub versions_time_cleanup {
 218     my ($db) = @_;
 219     my $time = time;
 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}
 226                                        }
 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]};
 234                 }
 235             }
 236         }
 237         $db->{$package} = $temp;
 238     }
 239 }