#!/usr/bin/perl

# perl script originally by hallon@debian.org, much faster than sed & sh.
#
# modified by cas to pipe its output through frcode and then > to the
# db file.
#
# caching of .list timestamps and re-use of old locatedb data added by 
# Pawel Chmielowski <prefiks@prefiks.org>, see Bug #457572

# 2009-05-30   Craig Sanders <cas@taz.net.au>
# - rewrote script to output a plain text listing rather than use frcode
#
# 2009-06-03 # Craig Sanders <cas@taz.net.au>
# - added optional support for compressing /var/lib/dlocatedb

use strict;
use File::Basename;

my $program = basename($0);

my $dbfile='/var/lib/dlocate/dlocatedb';
my $stampsfile='/var/lib/dlocate/dlocatedb.stamps';
#my $dbfile='/tmp/dlocate';
#my $stampsfile='/tmp/dlocate.stamps';
my $infodir='/var/lib/dpkg/info';

my $compress=0;
my $defaults='/etc/default/dlocate';
if (open(DEFAULTS,'<', $defaults)) {
    while (<DEFAULTS>) {
        chomp;
        s/#.*|^\s*|\s*$//g;
        next if (/^$/);
        s/\s|"//g;
        my ($key,$val) = split /=/;
        if ($key eq 'COMPRESS_DLOCATE') {
            $compress = $val;
        };
    };
    close(DEFAULTS);
};

my (%old_stamps, %stamps);

if (open(STAMPS, '<', $stampsfile)) {
    while (<STAMPS>) {
        chomp;
        my ($stamp, $file) = split /:/, $_, 2;
        $old_stamps{$file} = $stamp;
    }
    close(STAMPS);
}

open(DBFILE,'>', "$dbfile.new") or die "$program: couldn't open $dbfile.new for write: $!\n";

opendir(DIR, $infodir) or die "$program: can't open directory $infodir: $!\n";
while (defined(my $pkg = readdir(DIR))) {
    next unless $pkg =~ s/\.list$// and -s "$infodir/$pkg.list";
    $stamps{$pkg} = (stat(_))[10]; #ctime
}
closedir DIR;

my @new_pkgs;
my %processed;

chdir $infodir;
if (%old_stamps and open(DB, '<', $dbfile)) {
    while (<DB>) {
        my ($pkg) = /^(\S+?):/;
        if (not exists $stamps{$pkg}) {
            # skip packages which are no longer installed
        } elsif (exists $old_stamps{$pkg} and $stamps{$pkg} == $old_stamps{$pkg}) {
            print DBFILE $_;
        } elsif (not exists $processed{$pkg}) {
            open(FILE, "$pkg.list") or die "$program: can't open file $pkg.list: $!\n";
            foreach (<FILE>) {
                print DBFILE "$pkg: $_";
            }
            close FILE;
        }
        $processed{$pkg} = 1;
    }
    close(DB);

    my %tmp = %stamps;
    delete $tmp{$_} for keys %processed;
    @new_pkgs = keys %tmp;
} else {
    @new_pkgs = keys %stamps;
}

foreach my $pkg (@new_pkgs) {
    open(FILE, '<', "$pkg.list") or die "$program: can't open $pkg for read: $!\n";
    foreach (<FILE>) {
        print DBFILE $pkg, ': ', $_;
    }
    close FILE;
}

# append diversions info to dlocatedb
my $divfile = '/var/lib/dpkg/diversions';

open(DIVERSIONS,"<",$divfile) or die "$program: can't open $divfile for read: $!\n";
while (my $from = <DIVERSIONS>) {
  my $to = <DIVERSIONS>;
  my $pkg = <DIVERSIONS>;
  chomp($from, $to, $pkg);
  print DBFILE "diversion by $pkg from: $from\n";
  print DBFILE "diversion by $pkg to: $to\n";
}
close(DIVERSIONS);


close DBFILE;

# Create a backup to the database before replacing it with the new database.
# This is effectively two rename's done atomically.
if (-e $dbfile) {
    unlink("$dbfile.old") if (-e "$dbfile.old");
    link($dbfile, "$dbfile.old") if (-e $dbfile);
}

rename("$dbfile.new", $dbfile);

# optionally compress dlocatedb
if ($compress eq "1") {
    system('gzip','--quiet','--force',$dbfile);
    rename("$dbfile.gz", $dbfile);
};

open(STAMPS, '>', "$stampsfile.new") or die "$program: can't create stamps file $stampsfile.new: $!\n";
print STAMPS "$stamps{$_}:$_\n" for keys %stamps;
close STAMPS;

if (-e $stampsfile) {
  unlink($stampsfile);
};
rename("$stampsfile.new", $stampsfile);