update-archeos-menu

#!/usr/bin/perl

use warnings;
use strict;

use Dpkg::ErrorHandling;
use Dpkg::IPC;

use File::FcntlLock;
use File::Copy;
use File::Path qw(make_path);

use constant {
    INCOMING_APPDIR => "/usr/share/archeos-menu/applications",
    OUTGOING_APPDIR => "/usr/share/applications",
    DPKG_LOCKFILE => "/var/lib/dpkg/lock",
    ARCHEOS_MENU_LOCKFILE => "/var/lock/archeos-menu",
};

our %pkg2desktop;
our %desktop2pkg;
our %installed;

make_path(OUTGOING_APPDIR, { mode => 0755 });

my $lock = get_lock(); # Can stop here if another instance is already running

parse_archeos_desktop_files();

my $arg = shift @ARGV || "";
wait_dpkg() if (defined $ENV{'DPKG_RUNNING_VERSION'} or $arg eq "wait_dpkg");

# Scan installed packages to identify desktop files to install
foreach my $pkg (list_installed_packages()) {
    $installed{$pkg} = 1;
    next unless exists $pkg2desktop{$pkg};
    foreach my $desktop (@{$pkg2desktop{$pkg}}) {
	my $target = OUTGOING_APPDIR .  "/$desktop";
	my $source = INCOMING_APPDIR . "/$desktop";
	take_control_of($target);
	copy($source, $target);
    }
}

# Scan installed desktop files to remove the entries that are no longer
# relevant
FILE: foreach my $desktop (list_installed_desktop_files()) {
    my $ref_file = INCOMING_APPDIR . "/$desktop";
    my $out_file = OUTGOING_APPDIR . "/$desktop";
    next unless is_managed($out_file);
    # Drop unknown files
    unless (-e $ref_file and exists $desktop2pkg{$desktop}) {
	release_desktop_file($out_file);
	next;
    }
    # Ensure the corresponding package is still installed
    foreach my $pkg (@{$desktop2pkg{$desktop}}) {
	next FILE if $installed{$pkg};
    }
    release_desktop_file($out_file);
}

close($lock);

### HELPER FUNCTIONS

sub release_desktop_file {
    my ($file) = @_;
    my $infos = get_dpkg_infos($file);
    unlink($file) or syserr("can't remove %s", $file);
    remove_diversion($file) if $infos->{'diverted'};
}

sub take_control_of {
    my ($target) = @_;
    return if not -e $target; # No conflicting file, go ahead
    return if is_managed($target); # Already managed, nothing else to do
    my $infos = get_dpkg_infos($target);
    if ($infos->{'known'} and not $infos->{'diverted'}) {
	divert($target);
    }
}

sub get_dpkg_infos {
    my ($target) = @_;
    my $pipe;
    my $pid = spawn(exec => [ 'dpkg-query', '-S', $target ],
                    to_pipe => \$pipe, error_to_file => "/dev/null",
		    env => { LC_ALL => 'C' });
    my $res = {
	diverted => 0,
	known => 0,
    };
    while (<$pipe>) {
	if (/^(diversion by|local diversion)/) {
	    $res->{'diverted'} = 1;
	    next;
	}
	$res->{'known'} = 1 if /: \Q$target\E/;
    }
    wait_child($pid, cmdline => "dpkg-query -S $target", nocheck => 1);
    return $res;

}

sub divert {
    my ($target) = @_;
    spawn(exec => [ "dpkg-divert", "--local", "--rename", "--divert",
                    "$target.disabled-by-archeos-menu", "--add", $target ],
	  wait_child => 1, to_file => "/dev/null");
}

sub remove_diversion {
    my ($target) = @_;
    spawn(exec => [ "dpkg-divert", "--local", "--rename", "--divert",
                    "$target.disabled-by-archeos-menu", "--remove", $target ],
	  wait_child => 1, to_file => "/dev/null");
}

sub is_managed {
    my ($target) = @_;
    my $res = 0;
    open(my $fh, "<", $target) or syserr("can't open %s", $target);
    if (grep { /^X-Archeos-Package=/i } <$fh>) {
	$res = 1;
    }
    close($fh);
    return $res;
}

sub list_installed_packages {
    my (@list, $pipe);
    my $pid = spawn(exec => [ 'dpkg-query', '-f', '${Package} ${Status}\n', '-W' ],
                    to_pipe => \$pipe);
    while (<$pipe>) {
	my ($pkg, $want, $ok, $status) = split;
	if ($status ne "not-installed" and $status ne "config-files") {
	    push @list, $pkg;
	}
    }
    wait_child($pid, cmdline => "dpkg-query");
    return @list;
}

sub list_installed_desktop_files {
    opendir(my $dh, OUTGOING_APPDIR) or syserr("can't opendir %s", OUTGOING_APPDIR);
    my @files = grep(/\.desktop$/, readdir($dh));
    closedir($dh);
    return @files;
}

sub parse_archeos_desktop_files {
    opendir(my $dh, INCOMING_APPDIR) or syserr("can't opendir %s", INCOMING_APPDIR);
    foreach my $file (readdir $dh) {
	next unless ($file =~ /\.desktop$/);
	my $path = INCOMING_APPDIR . "/$file";
	open(my $fh, "<", $path) or syserr("can't open %s", $path);
	my $found = 0;
	while (<$fh>) {
	    if (/X-Archeos-Package=\s*(.*)$/i) {
		$found = 1;
		foreach my $pkg (split(/\s+|\s*,\s*/, $1)) {
		    $pkg2desktop{$pkg} = [] unless exists $pkg2desktop{$pkg};
		    $desktop2pkg{$file} = [] unless exists $desktop2pkg{$file};
		    push @{$pkg2desktop{$pkg}}, $file;
		    push @{$desktop2pkg{$file}}, $pkg;
		}
	    }
	}
	close($fh);
	unless ($found) {
	    warning("%s is missing the X-Archeos-Package header", $path);
	}
    }
    closedir($dh);
}

sub get_lock {
    my $lockfile = ARCHEOS_MENU_LOCKFILE;
    system("mkdir -p /run/lock /var/lock; touch $lockfile") unless -e $lockfile;
    open my $fh, '>>', $lockfile or syserr("Can't open %s", $lockfile);
    my $fs = new File::FcntlLock l_type => F_WRLCK;
    if (not $fs->lock($fh, F_SETLK)) {
	exit 0; # Failed to lock, another instance is already running
    }
    return $fh;
}

sub wait_dpkg {
    return unless -e DPKG_LOCKFILE;
    open my $fh, '<', DPKG_LOCKFILE or syserr("Can't open %s", DPKG_LOCKFILE);
    my $fs = new File::FcntlLock l_type => F_WRLCK;
    # Wait until dpkg releases the lock and doesn't grab it back in the
    # next 5 seconds
    my $count = 0;
    while ($count < 2) {
	if (can_lock($fh, $fs)) {
	    $count++;
	} else {
	    $count = 0;
	}
	sleep(5);
    }
    close $fh;
}

sub can_lock {
    my ($fh, $fs) = @_;
    $fs->l_type(F_WRLCK);
    if (not $fs->lock($fh, F_GETLK)) {
	error("Failed to analyze lock on %s: %s", DPKG_LOCKFILE, $fs->error());
    }
    return $fs->l_type == F_UNLCK;
}