parse-contents: Code clean-up
[deb/packages.git] / bin / parse-contents
1 #!/usr/bin/perl -w
2 # Convert Contents.gz files into Sleepycat db files for efficient usage of
3 # data
4 #
5 # Copyright (C) 2006  Jeroen van Wolffelaar <jeroen@wolffelaar.nl>
6 # This program is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 2 of the License, or
9 # (at your option) any later version.
10
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 # GNU General Public License for more details.
15
16 # You should have received a copy of the GNU General Public License
17 # along with this program; if not, write to the Free Software
18 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20 use strict;
21 use warnings;
22 use lib './lib';
23
24 $| = 1;
25
26 # Important, we want sorting and such to happen like in the C locale: binary,
27 # without any fancy collation. FIXME: is this actually adequate?
28 $ENV{"LC_ALL"} = 'C';
29
30 my $what = $ARGV[0] ? "head -10000|" : "";
31
32 # More RAM vs more disk I/O tradeoff parameters, does not change
33 # functionality. True will always use more RAM at the benefit of less
34 # temporary files, and is adviced when possible
35 my $SORT_REVERSE_CONCURRENTLY = 1;
36
37 use English;
38 use DB_File;
39 use Storable;
40 use File::Path;
41 use Packages::CommonCode qw(:all);
42 use Packages::Config qw( $TOPDIR $DBDIR @ARCHIVES @SUITES @ARCHITECTURES );
43 &Packages::Config::init( './' );
44
45 my @archives = @ARCHIVES;
46 my @suites = @SUITES;
47 my @archs = @ARCHITECTURES;
48
49 $DBDIR .= "/contents";
50 mkdirp( $DBDIR );
51
52 for my $suite (@suites) {
53     for my $arch (@archs) {
54
55         my $filelist_db = "$DBDIR/filelists_${suite}_${arch}.db";
56         my $dbtime = (stat $filelist_db)[9];
57         my %packages_contents = ();
58         my %packages_contents_nr = ();
59         my %packages_contents_lastword = ();
60
61         my $extra = "";
62         $extra = "|sort" if $SORT_REVERSE_CONCURRENTLY;
63
64         open REVERSED, "$extra>$DBDIR/reverse.tmp"
65             or die "Failed to open output reverse file: $!";
66
67         my $changed = 0;
68         for my $archive (@archives) {
69
70             my $filename = "$TOPDIR/archive/$archive/$suite/Contents-$arch.gz";
71             next unless -f $filename;
72             # Note: ctime, because mtime is set back via rsync
73             my $ftime = (stat $filename)[10];
74             next if defined $dbtime and $dbtime > $ftime;
75             print "$archive/$suite/$arch needs update\n";
76             $changed++;
77         }
78         if ($changed) {
79             for my $archive (@archives) {
80
81                 my $filename = "$TOPDIR/archive/$archive/$suite/Contents-$arch.gz";
82                 next unless -f $filename;
83                 print "Reading $archive/$suite/$arch...\n";
84
85                 open CONT, "zcat $filename|$what"
86                     or die $!;
87                 while (<CONT>) { last if /^FILE/mo; }
88                 if (eof(CONT)) { # no header found
89                     close CONT; # explicit close to reset $.
90                     open CONT, "zcat $filename|$what";
91                 }
92                 while (<CONT>) {
93                     my $data = "";
94                     my %data = ();
95                     chomp;
96                     print "Doing line ".($NR/1000)."k (out of approx 2.0M)\n"
97                         if $NR % 250000 == 0;
98                     /^(.+?)\s+(\S+)$/o;
99                     my ($file, $value) = ($1, $2);
100                     $value =~ s#[^,/]+/##og;
101                     my @packages = split m/,/, $value;
102                     for (@packages) {
103                         $packages_contents_nr{$_}++;
104                         my $lw = $packages_contents_lastword{$_} || "\0";
105                         my $i=0;
106                         while (substr($file,$i,1) eq substr($lw,$i++,1)) {}
107                         $i--;
108                         $i = 255 if $i > 255;
109                         $packages_contents{$_} .= pack "CC/a*", ($i, substr($file, $i));
110                         $packages_contents_lastword{$_} = "$file\0";
111                     }
112                     # Searches are case-insensitive
113                     (my $nocase = $file) =~ tr [A-Z] [a-z];
114                     my $case = ($nocase eq $file) ? '-' : $file;
115
116                     print REVERSED (reverse $nocase)."\0".$case."\0".
117                         (join ":$arch\0", @packages).":$arch\n";
118                 }
119                 close CONT;
120
121             }
122             close REVERSED;
123
124             print "Sorting reverse list if needed\n";
125             system("cd $DBDIR && sort reverse.tmp > reverse.sorted &&".
126                    " mv reverse.{sorted,tmp}") == 0
127                    or die "Failed to sort reverse"
128                    unless $SORT_REVERSE_CONCURRENTLY;
129
130             print "Writing filelist db\n";
131             tie my %packages_contents_db, "DB_File", "$filelist_db.new",
132             O_RDWR|O_CREAT, 0666, $DB_BTREE
133                 or die "Error creating DB: $!";
134             while (my ($k, $v) = each(%packages_contents)) {
135                 $packages_contents_db{$k} = (pack "L", $packages_contents_nr{$k})
136                     . $v;
137             }
138             untie %packages_contents_db;
139
140             rename("$DBDIR/reverse.tmp", "$DBDIR/reverse_${suite}_${arch}.txt");
141
142             activate($filelist_db);
143             system("ln", "-sf", $filelist_db,
144                    "$DBDIR/filelists_${suite}_all.db") == 0
145                        or die "Oops";
146         }
147     }
148
149     my $go = 0;
150     my $suite_mtime = (stat "$DBDIR/reverse_$suite.db")[9];
151     for my $file (glob "$DBDIR/reverse_${suite}_*.txt") {
152         $go = 1 if not defined $suite_mtime
153             or $suite_mtime < (stat $file)[9];
154     }
155     next unless $go;
156
157     print "Merging reverse path lists for ${suite}...\n";
158
159     open MERGED, "-|", "sort -m $DBDIR/reverse_${suite}_*.txt"
160         or die "Failed to open merged list";
161     open FILENAMES, ">", "$DBDIR/filenames_$suite.txt.new"
162         or die "Failed to open filenames list";
163     tie my %reverse_path_db, "DB_File", "$DBDIR/reverse_${suite}.db.new",
164         O_RDWR|O_CREAT, 0666, $DB_BTREE
165         or die "Error creating DB: $!";
166
167     my $lastpath = my $lastcasepath = my $lastfile = "";
168     my %matches = ();
169     while (<MERGED>) {
170         print "Doing line ".($NR/1000000)."M (out of approx. 20M)\n"
171             if $NR % 1000000 == 0;
172         chomp;
173         my @line = split m/\0/o, $_;
174         my $revpath = shift @line;
175         my $casepath = shift @line;
176         if ($revpath ne $lastpath) {
177             # Wrap: Do useful stuff with this ($lastpath, @matches)
178             if ($lastpath ne "") {
179                 my @matches;
180                 while (my ($k, $v) = each %matches) {
181                     push @matches, join("\0", $k, @$v);
182                 }
183                 $reverse_path_db{$lastpath} = join "\1", @matches;
184                 %matches = ();
185             }
186             $lastpath =~ s,/.*,,o;
187             if ($lastfile ne $lastpath) {
188                 $lastfile = $lastpath;
189                 print FILENAMES (reverse $lastfile)."\n";
190             }
191             #
192             $lastpath = $revpath;
193             $lastcasepath = $casepath;
194             $matches{$casepath} = \@line;
195             next;
196 #       } elsif ($lastcasepath ne "" and $casepath ne $lastcasepath) {
197 #           warn reverse($revpath)." has more than one casepath: $casepath $lastcasepath\n";
198         }
199         push @{$matches{$casepath}}, @line;
200     }
201     # Note: do useful stuff here too, for out last entry. Maybe prevent this by
202     # adding a fake ultimate entry?
203     {
204         my @matches;
205         while (my ($k, $v) = each %matches) {
206             push @matches, join("\0", $k, @$v);
207         }
208         $reverse_path_db{$lastpath} = join "\1", @matches;
209     }
210
211     untie %reverse_path_db;
212     close FILENAMES;
213     close MERGED;
214
215     activate("$DBDIR/filenames_$suite.txt");
216     activate("$DBDIR/reverse_$suite.db");
217 }
218
219 # vim: set ts=4