dlocate/updatedb

#!/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 warnings;

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 my $defaults_fh, '<', $defaults) {
    while (<$defaults_fh>) {
        chomp;
        s/#.*|^\s*|\s*$//g;
        next if (/^$/);
        s/\s|"//g;
        my ($key, $val) = split /=/;
        if ($key eq 'COMPRESS_DLOCATE') {
            $compress = $val;
        }
    }
    close $defaults_fh;
}

my (%old_stamps, %stamps);

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

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

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

my @new_pkgs;
my %processed;

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

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

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

# append diversions info to dlocatedb
my $divpipe = 'dpkg-divert --list \*';
open my $diversion_fh, "-|", $divpipe
    or die "$program: can't open pipe from '$divpipe': $!\n";
while (<$diversion_fh>) {
  print { $dbnew_fh } $_;
}
close $diversion_fh;

close $dbnew_fh;

# 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 my $stamps_fh, '>', "$stampsfile.new"
    or die "$program: can't create stamps file $stampsfile.new: $!\n";
print { $stamps_fh } "$stamps{$_}:$_\n" for keys %stamps;
close $stamps_fh;

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