]> git.donarmstrong.com Git - debbugs.git/blob - examples/debian/versions/build-versions-db
2d52c61c0724c71c7855d7b06dbcc79197d97eb3
[debbugs.git] / 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_time,$versions_time_new);
110 }
111 tie %db, "MLDBM", $versions_new, O_CREAT|O_RDWR, 0664
112     or die "tie $versions: $!";
113 tie %db2, "MLDBM", $versions_time_new,O_CREAT|O_RDWR, 0664
114      or die "tie $versions_time failed: $!";
115
116 update_versions_suites(\%db,\%db2,\@suites);
117 versions_time_cleanup(\%db2) if $options{update};
118
119 move($versions_new,$versions);
120 move($versions_time_new,$versions_time);
121
122 sub open_compressed_file {
123     my ($file) = @_;
124     my $fh;
125     my $mode = '<:encoding(UTF-8)';
126     my @opts;
127     if ($file =~ /\.gz$/) {
128         $mode = '-|:encoding(UTF-8)';
129         push @opts,'gzip','-dc';
130     }
131     if ($file =~ /\.xz$/) {
132         $mode = '-|:encoding(UTF-8)';
133         push @opts,'xz','-dc';
134     }
135     if ($file =~ /\.bz2$/) {
136         $mode = '-|:encoding(UTF-8)';
137         push @opts,'bzip2','-dc';
138     }
139     open($fh,$mode,@opts,$file);
140     return $fh;
141 }
142
143 # Read Package, Version, and Source fields from a Packages.gz file.
144 sub read_packages {
145     my ($db,$db2,$packages, $component,$arch,$dist) = @_;
146     my $PACKAGES = open_compressed_file($packages) or
147         die "Unable to open $packages for reading: $!";
148     local $_;
149     local $/ = '';      # paragraph mode
150
151     print STDERR "reading packages $packages\n" if $DEBUG;
152     for (<$PACKAGES>) {
153         /^Package: (.+)/im or next;
154         my $pkg = $1;
155         /^Version: (.+)/im or next;
156         my $ver = $1;
157         my $extra_source_only = 0;
158         if (/^Extra-Source-Only: yes/im) {
159             $extra_source_only = 1;
160         }
161         update_package_version($db,$db2,$dist,$arch,$pkg,$ver,$time) unless
162             $extra_source_only;
163     }
164 }
165
166
167 sub update_package_version {
168     my ($db,$db2,$d,$a,$p,$v,$t) = @_;
169     # see MLDBM(3pm)/BUGS
170     my $tmp = $db->{$p};
171     # we allow multiple versions in an architecture now; this
172     # should really only happen in the case of source, however.
173     push @{$tmp->{$d}{$a}}, $v;
174     $db->{$p} = $tmp;
175     $tmp = $db2->{$p};
176     $tmp->{$d}{$a}{$v} = $time if not exists
177         $tmp->{$d}{$a}{$v};
178     $db2->{$p} = $tmp;
179 }
180
181 sub update_versions_suites {
182     my ($db,$db2,$suites) = @_;
183 # Iterate through all Packages and Sources files.
184 for my $suite (@{$suites}) {
185     my $suitedir = "$toplevel/$suite";
186
187     for my $component ('main', 'main/debian-installer',
188                        'contrib', 'non-free') {
189         my $componentdir = "$suitedir/$component";
190         next unless -d $componentdir;
191         my $COMPONENT;
192         opendir $COMPONENT, $componentdir or die "opendir $componentdir: $!";
193
194         # debian-installer is really a section rather than a component
195         # (ugh).
196         (my $viscomponent = $component) =~ s[/.*][];
197
198         my $sources = (grep { -f $_ } glob "$suitedir/$component/source/Sources.*")[0];
199         next unless defined $sources;
200         read_packages($db,$db2,$sources, $viscomponent,'source',$suite);
201
202         for my $arch (readdir $COMPONENT) {
203             next unless $arch =~ s/^binary-//;
204             my $archdir = "$componentdir/binary-$arch";
205
206             my $packages = (grep { -f $_ } glob("$archdir/Packages.*"))[0];
207             next unless defined $packages;
208             read_packages($db,$db2,$packages, $viscomponent,$arch,$suite);
209         }
210
211         closedir $COMPONENT;
212     }
213 }
214 }
215
216 sub versions_time_cleanup {
217     my ($db) = @_;
218     my $time = time;
219     for my $package (keys %{$db}) {
220         my $temp = $db->{$package};
221         for my $dist (keys %{$temp}) {
222             for my $arch (keys %{$temp->{$dist}}) {
223                 my @versions =  (sort {$temp->{$dist}{$arch}{$a} <=>
224                                            $temp->{$dist}{$arch}{$b}
225                                        }
226                                  keys %{$temp->{$dist}{$arch}});
227                 next unless @versions > 1;
228                 for my $i (0 .. ($#versions-1)) {
229                     last if $temp->{$dist}{$arch}{$versions[$i+1]} >
230                         ($time - $config{remove_age}*60*60*24);
231                     last if keys %{$temp->{$dist}{$arch}} <= 1;
232                     delete $temp->{$dist}{$arch}{$versions[$i]};
233                 }
234             }
235         }
236         $db->{$package} = $temp;
237     }
238 }