#!/usr/bin/env perl

###########################################################################
#   Copyright (C) 2008-2013 by Eugene V. Lyubimkin                        #
#                                                                         #
#   This program is free software; you can redistribute it and/or modify  #
#   it under the terms of the GNU General Public License                  #
#   (version 3 or above) as published by the Free Software Foundation.    #
#                                                                         #
#   This program is distributed in the hope that it will be useful,       #
#   but WITHOUT ANY WARRANTY; without even the implied warranty of        #
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         #
#   GNU General Public License for more details.                          #
#                                                                         #
#   You should have received a copy of the GNU GPLv3                      #
#   along with this program; if not, write to the                         #
#   Free Software Foundation, Inc.,                                       #
#   51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA               #
###########################################################################

# Devoted to Evgeniya V. Katyuk.

package main;

sub include_description_in_pkg_list {
	return ($ENV{'DAPTUP_NEW_INCLUDE_DESCRIPTION'} // '') eq 'y';
}

sub get_pkg_list_description_filter {
	if (main::include_description_in_pkg_list()) {
		return '';
	} else {
		return " | sed -r -e 's/ -.*//'";
	}
}

package Daptup::Backend::AptOrCupt;

use strict;
use warnings;

my $preferred_version_sub_regex = '(?:Candidate|Preferred): (.+?)\n';

sub new {
	my $class = shift;
	my $type = shift;
	return bless { 'type' => $type } => $class;
}

sub get_cache_binary_name {
	my ($self) = @_;

	return ($self->{'type'} eq 'cupt') ? 'cupt -o cupt::cache::release-file-expiration::ignore=yes' : 'apt-cache';
}

sub get_avail_pkg_list {
	my ($self, $output_file, $errors_file) = @_;

	my $filter = main::get_pkg_list_description_filter();
	my $binary_name = $self->get_cache_binary_name();
	system(qq/$binary_name search ".*" 2>$errors_file $filter | sort | uniq > $output_file/);
}

sub get_updates {
	my ($self, $output_file) = @_;

	my $binary_name = $self->get_cache_binary_name();
	my $get_installed_package_names_command = q/dpkg -l | grep "^ii" | awk '{ gsub(":.*", "", $2); print $2 }'/;
	# shell may reject too long lists of arguments, xargs automatically handles that
	my $policy_output = `$get_installed_package_names_command | LC_MESSAGES=C xargs $binary_name policy 2>/dev/null`;

	# 'apt-cache policy' somewhy outputs blocks in random order, not as
	# specified in the command line (#......), use hash
	my %updateable_entries;

	foreach my $policy_output_block (split(/\n(?=[^ ])/, $policy_output)) {
		if ($policy_output_block =~ m/^(.+?):\n  Installed: (.+?)\n  $preferred_version_sub_regex/o) {
			if ($2 ne $3) {
				$updateable_entries{$1} = "$2 -> $3";
			}
		}
	}

	open(my $output_file_fd, '>', $output_file);
	foreach my $package_name (sort keys %updateable_entries) {
		say { $output_file_fd } "$package_name: $updateable_entries{$package_name}";
	}
	close($output_file_fd);
}

sub get_watched {
	my ($self, $output_file) = @_;

	my $regex = main::get_watch_regex();
	if ($regex) {
		my $binary_name = $self->get_cache_binary_name();

		my @watched_packages = split("\n", `$binary_name search --names-only "$regex" 2>/dev/null`);
		s/ .*// foreach @watched_packages;

		open(my $output_file_fd, '>', $output_file);
		foreach my $package_name (@watched_packages) {
			my $policy_output = `LC_MESSAGES=C $binary_name policy $package_name 2>/dev/null`;
			my ($version_string) = ($policy_output =~ m/$preferred_version_sub_regex/o);
			chomp($version_string);
			say $output_file_fd "$package_name $version_string";
		}
		close($output_file_fd);
	}
}

package Daptup::Backend::Aptitude;

use base qw(Daptup::Backend::AptOrCupt);

use strict;
use warnings;

sub new {
	my $class = shift;

	$ENV{'DAPTUP_EXTRA_APTITUDE_ARGUMENTS'} //= '';

	if ($ENV{'DAPTUP_DISABLE_COLUMNS'} eq 'y') {
		$ENV{'DAPTUP_EXTRA_APTITUDE_ARGUMENTS'} .= " --disable-columns"
	}

	return bless Daptup::Backend::AptOrCupt->new('apt') => $class;
}

sub get_avail_pkg_list {
	my ($self, $output_file, $errors_file) = @_;

	my $command = qq/aptitude search "~n(.*)"/;
	$command .= qq/ --display-format $ENV{DAPTUP_NEW_DISPLAY_FORMAT}/;
	$command .= qq/ --width $ENV{DAPTUP_NEW_DISPLAY_WIDTH}/;
	$command .= qq/ $ENV{DAPTUP_EXTRA_APTITUDE_ARGUMENTS}/;
	my $filter = main::get_pkg_list_description_filter();
	$command .= qq/	2> $errors_file $filter > $output_file /;

	system($command);
}

sub get_watched {
	my ($self, $output_file) = @_;

	my $regex = main::get_watch_regex();
	if ($regex) {
		my $command = qq/aptitude search "~n($regex)"/;
		$command .= qq/ --display-format $ENV{DAPTUP_WATCH_DISPLAY_FORMAT}/;
		$command .= qq/ --width "$ENV{DAPTUP_WATCH_DISPLAY_WIDTH}"/;
		$command .= qq! $ENV{DAPTUP_EXTRA_APTITUDE_ARGUMENTS} 2>/dev/null > $output_file!;
		system($command);
	}
}

package main;

use 5.10.0;
use strict;
use warnings;

use File::Temp qw(tempfile);
use File::Basename;
use Getopt::Long;
use Locale::gettext qw(gettext ngettext);
use Term::ANSIColor;

INIT { require Carp; $SIG{__WARN__} = \&Carp::confess; $SIG{__DIE__} = \&Carp::confess; }

$| = 1; # enabling autoflush

# translation support
Locale::gettext::textdomain("daptup");

sub lprint {
	my $pattern = shift;
	print (sprintf gettext($pattern), @_);
}

sub lsay {
	lprint(@_); print "\n";
}

my $spool_dir = '/var/spool/daptup';

# spool/cache files
my $updates_before_file = "$spool_dir/updates-before";
my $updates_after_file = "$spool_dir/updates-after";
my $new_before_file = "$spool_dir/new-before";
my $new_after_file = "$spool_dir/new-after";
my $watch_before_file = "$spool_dir/watch-before";
my $watch_after_file = "$spool_dir/watch-after";
my $outdated_file="$spool_dir/outdated";
# safe, self-destroying temporary files
my $errors_file_obj = new File::Temp();
my $temp_file_obj = new File::Temp();

$SIG{TERM} = sub { exit 1024; };
$SIG{INT} = sub { exit 1024; };

my $subcommand;
my $use_color = 1;

my $config_file = '/etc/daptup.conf';
if (-r $config_file) {
	# sourcing it to obtain configuration variables
	open(my $config_fd, '<', $config_file);
	while (<$config_fd>) {
		next if m/^\s*(#|$)/;
		my ($variable, $value) = m/^(\w+)=(.*)/;
		$ENV{$variable} = $value;
	}
	close($config_fd);
} else {
	lsay("Cannot read configuration from '%s'.", $config_file);
	exit 1
}

# determining backend to use
my $backend;
if (-x '/usr/bin/cupt') {
	$backend = Daptup::Backend::AptOrCupt->new('cupt');
} elsif (-x '/usr/bin/aptitude') {
	$backend = Daptup::Backend::Aptitude->new();
} else {
	$backend = Daptup::Backend::AptOrCupt->new('apt');
}

sub check_subcommand {
	my ($subcommand_name) = @_;
	if (defined $subcommand) {
		lsay("You cannot mix '--pre', '--post' and '--last' options or repeat them.");
		exit 4;
	} else {
		$subcommand = $subcommand_name;
	}
}

# processing options
GetOptions(
	'pre' => sub { check_subcommand('pre') },
	'post' => sub { check_subcommand('post') },
	'last' => sub { check_subcommand('last') },
	'nocolor' => sub { $use_color = 0; },
	'help|h' => sub {
		lsay("Usage: %s ( --pre | --post | --last ) [ -h | --help | --nocolor ].", basename($0));
		say "";
		lsay("daptup outputs:");
		lsay(" - list of packages recently entered to repo;");
		lsay(" - list of packages which got new updates;");
		lsay(" - list of changes in 'watched' packages;");
		lsay(" - list of outdated packages (optionally).");
		say "";
		lsay("Options:");
		lsay(" -h, --help: output this help and exit");
		lsay(" --nocolor: do not use colored output");
		lsay(" --pre: do only 'pre' stage: collect info that will be used as 'old'");
		lsay(" --post: do only 'post' stage: collect 'new' info and output changes");
		lsay("         if appropriate option is not disabled in config file");
		lsay(" --last: only output last changes");
		say "";
		exit 0;
	},
);

if ($ENV{"DAPTUP_USE_COLOR"} ne "y" || not $use_color) {
	$ENV{"ANSI_COLORS_DISABLED"} = 1;
}

sub get_watch_regex {
	my $regex = join('|', map { "^$_\$" } split(/ /, $ENV{"DAPTUP_PACKAGES_WATCH_FOR"}));
	$regex =~ s/"//g;

	return $regex;
}

if (not defined $subcommand) {
	lsay("You must specify a subcommand.");
	exit 16;
}

# Checking for root privileges
if ($< != 0 and ($subcommand ne 'last')) {
	lsay("You must run daptup with root privileges.");
	exit 2;
}

sub find_old_packages {
	my ($output_file) = @_;
	my $doc_dir = '/usr/share/doc';
	my $seconds_in_day = 24 * 60 * 60;
	my $current_timestamp = time();

	open(my $output_file_fd, '>', $output_file) or return;
	open(my $updates_file_fd, '<', $updates_after_file);
	while (my $line = <$updates_file_fd>) {
		chomp($line);
		my $package_name = $line;
		$package_name =~ s/:.*//;
		my $changelog_file;
		if (-f "$doc_dir/$package_name/changelog.Debian.gz") {
			$changelog_file = "$doc_dir/$package_name/changelog.Debian.gz";
		} elsif (-f "$doc_dir/$package_name/changelog.gz") {
			$changelog_file = "$doc_dir/$package_name/changelog.gz";
		} else {
			lsay("warning: cannot find any changelog for package '%s'", $package_name);
		}

		if (defined $changelog_file) { # if we've found a changelog
			my $last_modified_line=`zgrep -e "^ -- " $changelog_file | head -1`;
			if ($last_modified_line ne '') { # changelog is correct
				# extracting date
				# example: " -- James Troup <james@nocrew.org>  Mon, 24 Apr 2006 04:24:07 +0100"
				(my $date = $last_modified_line) =~ s/.*?([0-9 ][0-9] [A-Z][a-z][a-z] [0-9]{4}).*/$1/ or
						do { # date is extracted badly
							lsay("error: cannot extract last modification date for package '%s'", $package_name);
							next;
						};

				my $package_timestamp = `date -d "$date" +%s`;
				my $days = int(($current_timestamp - $package_timestamp) / $seconds_in_day);
				if ($days > $ENV{'DAPTUP_MINIMAL_DAY_COUNT_TREATING_OUTDATED'}) { # package is old
					say $output_file_fd "$line, $days " . ngettext("day", "days", $days);
				}
			} else { # changelog is not correct
				lsay("error: cannot fetch last entry from changelog for package '%s'", $package_name);
			}
		}
	}
	close($output_file_fd);
	close($updates_file_fd);
}

sub diff_cmd {
	my ($before_file, $after_file, $output_file) = @_;
	system(qq/diff --minimal $before_file $after_file | grep -E "^[<>]" | sort --key=2 -V > $output_file/);
}

sub do_pre {
	my $errors_file_path = $errors_file_obj->filename;
	lsay("Building old list of packages... ");
	$backend->get_avail_pkg_list($new_before_file, $errors_file_path);

	if (-s $errors_file_path and -z $new_before_file) {
		if (system("grep '^E:' $errors_file_path") == 0) {
			lsay("errors present. Is apt/dpkg running?");
			exit 8;
		}
	}

	lsay("Building old list of available updates... ");
	$backend->get_updates($updates_before_file);

	lsay("Building old list of watched packages... ");
	$backend->get_watched($watch_before_file);
}

sub do_post {
	if ($subcommand ne 'last') {
		lsay("Building new list of packages... ");
		$backend->get_avail_pkg_list($new_after_file, '/dev/null');

		lsay("Building new list of available updates... ");
		$backend->get_updates($updates_after_file);

		lsay("Building new list of watched packages... ");
		$backend->get_watched($watch_after_file);
	}

	if (($subcommand eq 'last') || $ENV{'DAPTUP_SHOW_CHANGES_IN_POST'} eq 'y') {
		# show changes
		my $output_outdated = 0;
		if ($ENV{'DAPTUP_CHECK_FOR_OUTDATED_PACKAGES'} eq 'y') {
			# if DAPTUP_MINIMAL_DAY_COUNT_TREATING_OUTDATED variable contains non-numeric
			# data, print an error and don't try to check for outdated packages
			if ($ENV{'DAPTUP_MINIMAL_DAY_COUNT_TREATING_OUTDATED'} !~ m/\D/) {
				lsay("Building list of outdated packages... ");
				find_old_packages($outdated_file);
				$output_outdated = 1;
			} else {
				lsay("error: DAPTUP_MINIMAL_DAY_COUNT_TREATING_OUTDATED contains non-numeric data");
			}
		} else {
			lsay("Skipping check for outdated packages.");
		}

		say("");

		diff_cmd($updates_before_file, $updates_after_file, $temp_file_obj->filename);
		if (-z $temp_file_obj->filename) {
			lsay("No new updates.");
		} else {
			lsay("New updates:");
			open(my $tmp_file_fd, '<', $temp_file_obj->filename);
			while (<$tmp_file_fd>) {
				if (substr($_, 0, 1) eq '<') {
					print color 'red';
				} else {
					print color 'green';
				}
				print;
			}
			close($tmp_file_fd);
		}

		print color 'reset';

		diff_cmd($new_before_file, $new_after_file, $temp_file_obj->filename);
		if (-z $temp_file_obj->filename) {
			lsay("No new or removed packages.");
		} else {
			lsay("New and removed packages:");
			open(my $tmp_file_fd, '<', $temp_file_obj->filename);
			while (<$tmp_file_fd>) {
				if (substr($_, 0, 1) eq '<') {
					print color 'red';
				} else {
					print color 'cyan';
				}
				print;
			}
			close($tmp_file_fd);
		}

		print color 'reset';

		diff_cmd($watch_before_file, $watch_after_file, $temp_file_obj->filename);
		if (-z $temp_file_obj->filename) {
			lsay("No news in watched packages.");
		} else {
			lsay("Changes in watched packages:");
			open(my $tmp_file_fd, '<', $temp_file_obj->filename);
			while (<$tmp_file_fd>) {
				if (substr($_, 0, 1) eq '<') {
					print color 'red';
				} else {
					print color 'green';
				}
				print;
			}
			close($tmp_file_fd);
		}

		print color 'reset';

		if ($output_outdated) {
			if (-z $outdated_file) {
				lsay("No outdated packages.");
			} else {
				lsay("Outdated packages:");
				print color 'magenta';
				open(my $outdated_file_fd, '<', $outdated_file);
				while (<$outdated_file_fd>) {
					s/^/  /;
					print;
				}
				close($outdated_file_fd);
			}
		}

		print color 'reset';
	}
}

# start of program
if ($subcommand eq 'pre') {
	do_pre();
} else { # post or last
	do_post();
}

exit 0;