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<--debug, -d>
  34
  35 Debug verbosity. (Default 0)
  36
  37 =item B<--help, -h>
  38
  39 Display brief usage information.
  40
  41 =item B<--man, -m>
  42
  43 Display this manual.
  44
  45 =back
  46
  47 =head1 EXAMPLES
  48
  49      build-versions-db versions.idx.new versions.idx.new \
  50            /srv/bugs.debian.org/versions/indices/ftp \
  51            stable
  52
  53 =cut
  54
  55
  56 use vars qw($DEBUG);
  57 use Debbugs::Versions::Dpkg;
  58 use IO::Uncompress::AnyUncompress;
  59 use MLDBM qw(DB_File Storable);
  60 use Fcntl;
  61
  62 my %options = (debug           => 0,
  63                help            => 0,
  64                man             => 0,
  65                compprefix      => '',
  66               );
  67
  68 GetOptions(\%options,
  69            'hostname=s',
  70            'compprefix=s',
  71            'debug|d+','help|h|?','man|m');
  72
  73 pod2usage() if $options{help};
  74 pod2usage({verbose=>2}) if $options{man};
  75
  76 $DEBUG = $options{debug};
  77
  78 my @USAGE_ERRORS;
  79 if (not defined $options{hostname}) {
  80     push @USAGE_ERRORS,"You must provide a hostname";
  81 }
  82
  83 if (not @ARGV >= 4) {
  84     push @USAGE_ERRORS,
  85         "You must provide at least four arguments, two databases, ".
  86         "a top level directory and at least one suite";
  87 }
  88
  89 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  90
  91
  92 my $versions = shift @ARGV;
  93 my $versions_time = shift @ARGV;
  94 my $toplevel = shift @ARGV;
  95 my @suites = @ARGV;
  96
  97 $MLDBM::DumpMeth=q(portable);
  98
  99 my $time = time;
 100
 101 my %db;
 102 my %db2;
 103 tie %db, "MLDBM", $versions, O_CREAT|O_RDWR, 0664
 104     or die "tie $versions: $!";
 105 tie %db2, "MLDBM", $versions_time,O_CREAT|O_RDWR, 0664
 106      or die "tie $versions_time failed: $!";
 107
 108 # Read Package, Version, and Source fields from a Packages.gz file.
 109 sub read_packages {
 110     my ($packages, $component,$arch,$dist) = @_;
 111     my $PACKAGES = IO::Uncompress::AnyUncompress->new($packages) or
 112         die "Unable to open $packages for reading: $!";
 113     local $_;
 114     local $/ = '';      # paragraph mode
 115
 116     print STDERR "reading packages $packages\n" if $DEBUG;
 117     for (<$PACKAGES>) {
 118         /^Package: (.+)/im or next;
 119         my $pkg = $1;
 120         /^Version: (.+)/im or next;
 121         my $ver = $1;
 122         my $extra_source_only = 0;
 123         if (/^Extra-Source-Only: yes/im) {
 124             $extra_source_only = 1;
 125         }
 126         update_package_version($dist,$arch,$pkg,$ver,$time) unless
 127             $extra_source_only;
 128     }
 129 }
 130
 131
 132 sub update_package_version {
 133     my ($d,$a,$p,$v,$t) = @_;
 134     # see MLDBM(3pm)/BUGS
 135     my $tmp = $db{$p};
 136     # we allow multiple versions in an architecture now; this
 137     # should really only happen in the case of source, however.
 138     push @{$tmp->{$d}{$a}}, $v;
 139     $db{$p} = $tmp;
 140     $tmp = $db2{$p};
 141     $tmp->{$d}{$a}{$v} = $time if not exists
 142         $tmp->{$d}{$a}{$v};
 143     $db2{$p} = $tmp;
 144 }
 145
 146 # Iterate through all Packages and Sources files.
 147 for my $suite (@suites) {
 148     my $suitedir = "$toplevel/$suite";
 149
 150     for my $component ('main', 'main/debian-installer',
 151                        'contrib', 'non-free') {
 152         my $componentdir = "$suitedir/$component";
 153         next unless -d $componentdir;
 154         my $COMPONENT;
 155         opendir $COMPONENT, $componentdir or die "opendir $componentdir: $!";
 156
 157         # debian-installer is really a section rather than a component
 158         # (ugh).
 159         (my $viscomponent = $component) =~ s[/.*][];
 160         $viscomponent = $options{compprefix} . $viscomponent;
 161
 162         my $sources = (grep { -f $_ } glob "$suitedir/$component/source/Sources.*")[0];
 163         next unless defined $sources;
 164         read_packages($sources, $viscomponent,'source',$suite);
 165
 166         for my $arch (readdir $COMPONENT) {
 167             next unless $arch =~ s/^binary-//;
 168             my $archdir = "$componentdir/binary-$arch";
 169
 170             my $packages = (grep { -f $_ } glob("$archdir/Packages.*"))[0];
 171             next unless defined $packages;
 172             read_packages($packages, $viscomponent,$arch,$suite);
 173         }
 174
 175         closedir $COMPONENT;
 176     }
 177 }
 178
 179