#!/usr/bin/perl

#
#      apt-listchanges - Show changelog entries between the installed versions
#        of a set of packages and the versions contained in corresponding
#        .deb files
#
#      Copyright (C) 2000, 2001  Matt Zimmerman <mdz@debian.org>
#
#      This program is free software; you can redistribute it and/or modify
#      it under the terms of the GNU General Public License as published by
#      the Free Software Foundation; either version 2 of the License, or
#      (at your option) any later version.
#
#      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 General Public
#      License along with this program; if not, write to the Free
#      Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
#      MA 02111-1307 USA
#

#      RPM changes by Claudio Matsuoka <claudio@conectiva.com>
#      (Tue Dec  5 12:25:17 EST 2000)
#
#      * changed dpkg-deb queries to rpm --queryformat
#      * changed status reading from /var/lib/dpkg/status to `rpm -qa`
#
#      Notes:
#
#      1. urgency is ignored (not supported by RPM)
#      2. it gets confused with multiple versions released in the same day
#         (will fix that later)

use strict;
use Getopt::Long;
use Sys::Hostname;
use IO::Handle;
use Locale::gettext;
use POSIX qw(setlocale);

# Initialize locale settings
setlocale(LC_MESSAGES, '');
textdomain('apt-listchanges');

# Read config file
my %config;
&read_config('/etc/apt/listchanges.conf', \%config);

my $usage = "Usage: apt-listchanges [options] {--apt | filename.rpm ...}\n";

my $sensible_pager = $ENV{PAGER} || "/usr/bin/less"; 

# Config file options can be overridden by command line options
my $apt_mode = 0;
my $verbose = 0;
my $frontend_opt = $config{'frontend'} || 'pager';
my $email_address = $config{'email-address'} || 'root';
my $show_all = 0;
my $apt_mode_run = $config{'apt-mode-run'} ?
    $config{'apt-mode-run'} eq 'yes' : 0;
my $confirm;
my $show_headers = 0;
my $version_only = 0;
my $help_only = 0;

GetOptions("apt" => \$apt_mode,
	   "verbose|v" => \$verbose,
	   "frontend|f=s" => \$frontend_opt,
	   "email-address=s" => \$email_address,
	   "confirm|c!" => \$confirm,
	   "all|a" => \$show_all,
	   "headers|h" => \$show_headers,
	   "help" => \$help_only,
	   "version" => \$version_only) || die $usage;

if ($version_only) {
  print "apt-listchanges version 1.49\n";
  exit 0;
}

if ($help_only) {
  print $usage;
  exit 0;
}

if ($apt_mode && undef($confirm)) {
  $confirm ||= ( $config{'apt-mode-confirm'} eq 'yes' );
}

# Hash of package info from the status file
my %status;

# Hash of array refs mapping source to binary packages
my %binary_packages;

# A separate hash of source packages used to avoid duplicates, updated
# when we find changelogs to display for a package
my %processed;

# The number of packages we've successfully examined (even if we
# didn't find anything to display)
my $valid = 0;

# Numeric urgency values for sorting.  Unknown urgencies get sorted to
# the top (equivalent to 'high'), since there is no fixed list of
# urgency values and it would be much more probable that an unknown
# urgency value would be higher than lower ("this package needs to get
# out at extra-low priority!")
my %urgency_map = ( 'low' => 2,
		    'medium' => 1,
		    'high' => 0 );

# Changelog text and urgency, by source package
my %changes;
my %urgency;

# Error text
my $errors;

# Informational notes
my $notes;

##
## Initialization
##

my @debs = read_rpm_filenames($apt_mode, \%status);

# We have to read all data from the pipeline before exiting, or apt
# will complain
exit 0 if ($apt_mode && !$apt_mode_run);

# If apt is in quiet mode, we should make ourselves loggable too
if ($config{'quiet'} && $frontend_opt ne 'mail') {
  $frontend_opt = 'text';
}

if (!$show_all) {
  rpm_read_status(\%status);
}

unless (@debs) {
  exit 0 if ($apt_mode);
  die "apt-listchanges: " .
      gettext("Must specify either --apt or filenames to process!") . "\n";
}

# User interaction
my $frontend = frontend_init($frontend_opt);
my @changes;

##
## Main loop
##
foreach my $deb (@debs) {
  &{ $frontend->{update_progress} }($frontend);

  # Find out what package we are installing
  my ($pkg, $version, $oldversion, $sourcepackage, $lastchange) =
      rpm_get_package_info($deb, \%status);

  # Bail if things don't look right
  unless ($pkg) {
    $errors .= "apt-listchanges: " .
	sprintf(gettext("Unable to determine package name for file %s"), $deb)
	    . "\n";
    next;
  }
  unless ($version) {
    $errors .= "apt-listchanges: " .
	sprintf(gettext("Unable to determine version for file %s"), $deb)
	    . "\n";
    next;
  }

  ++$valid;

  # Skip if the package is not installed
  if (!$show_all && !$oldversion) {
    $notes .=
	sprintf(gettext("%s: will be newly installed"), $pkg)
	    . "\n\n";
    next;
  }

  # Skip if we are looking at the same version (faster than asking dpkg)
  if ($version eq $oldversion) {
    $notes .=
	sprintf(gettext("%s: Version $version is already installed"),
		$pkg)
	    . "\n\n";
    next;
  }

  # Skip if we are looking at an older version
  if (!$show_all && rpm_compare_versions($version, 'le', $oldversion)) {
    $notes .=
	sprintf(gettext("%s: Version %s is older than installed version (%s)"),
		$pkg, $version, $oldversion)
	    . "\n\n";
    next;
  }

  # Add to the list of binary packages belonging to this source package
  if (defined $binary_packages{$sourcepackage}) {
    push(@{$binary_packages{$sourcepackage}}, $pkg);
  } else {
    $binary_packages{$sourcepackage} = [$pkg];
  }

  # Skip if we already processed another binary package from this
  # source package
  next if $processed{$sourcepackage};

  # Determine the changelog filenames
  my @changelog_filenames = ('changelog.Debian');

  # Check both compressed and uncompressed
  @changelog_filenames = map { ($_, "$_.gz") } @changelog_filenames;

  # Check both /usr/doc and /usr/share/doc
  @changelog_filenames = map { ("./usr/doc/\\*/$_",
				  "./usr/share/doc/\\*/$_") }
				  @changelog_filenames;

  my @changelog_filenames_nodebian = @changelog_filenames;

  # Strip .Debian to check native packages
  # map { s/\.Debian//g } @changelog_filenames_nodebian;

  open(DPKGDEB, "rpm -qp --changelog $deb|") || die $!;
  my $lines_read = 0;
  my $urgency = 0;
  my $changes = "====[ $pkg $version ]====\n\n";
  while (<DPKGDEB>) {
    ++$lines_read;
 
    if (/^\* (.*)$/) {
      my $change = $1;
      last if ($lastchange eq $change);
    }

    $changes .= $_;
  }
 
  $changes[$urgency] .= $changes if $changes;

  # Read any remaining data from a large changelog, to avoid a 'broken
  # pipe' error message on close
  while (<DPKGDEB>) {}
  close(DPKGDEB);
 
  # ++$source_packages_processed{$sourcepackage};

}

if ($valid == 0) {
  # If we didn't find any valid packages, give the user a hint
  die "apt-listchanges: didn't find any valid .rpm archives\n$usage";
}

# # Prepend binary package info
# if ($show_headers) {
#   foreach my $pkg (keys %changes) {
#     my @binary_packages = @{$binary_packages{$pkg}};
#     my $binary_text;
#     
#     if (@binary_packages == 1 && $binary_packages[0] eq $pkg) {
#       $binary_text = "";
#     } else {
#       $binary_text = "(@binary_packages) ";
#     }
#     
#     $changes{$pkg} = "--- " .
# 	sprintf(gettext("Changes for %s"), $pkg)
# 	    . " $binary_text ---\n"
# 		. $changes{$pkg};
#   }
# }

#my @packages_by_urgency = sort { $urgency{$a} <=> $urgency{$b} } keys %changes;

# Concatenate all the changes, ordered by urgency
#my $output = join('', map { $changes{$_} } @packages_by_urgency);
my $output = $changes[0];
if ($verbose) {
  $output .= "\n" . gettext("Informational notes") . ":\n\n$notes";
}

if ($errors) {
  $output .= "\napt-listchanges: ". gettext("Error output follows") . "\n";
  $output .= $errors;
}

# Display the output using the frontend
&{ $frontend->{display_output} }($frontend, $output);

if ($confirm && $output) {
  exit 10 unless &{ $frontend->{confirm} }($frontend);
}

exit 0;

## End top level ##

# Initialize the frontend...this is a little bit hairy.  We return a
# reference (really, a fake object) containing subroutine refs These
# expect to be called with a reference to the fake object as their
# first argument, just as a real object's methods would.  The code for
# all of the frontends is in here.
#
# The subroutine refs are:
#
# init - Initialize the frontend
# update_progress - update a progress meter
# display_output - Show the user some text
# confirm - Ask the user whether to continue (return false if not)
#

sub frontend_init {
  my ($frontend_opt) = @_;
  
  my %frontends;

  $frontends{'newt'} = {
    'init' => sub {
      my ($this) = @_;

      $this->{newt} = {};

      # Initialize terminal graphics
      eval q{ use Newt; };
      if ($@) {
	warn "apt-listchanges: " .
	    gettext("In order to use the newt frontend, you must install libnewt-perl")
		. "\n";
	return undef;
      }

    Newt::Init();
    Newt::Cls();
      my ($screen_width, $screen_height) = Newt::GetScreenSize();
      
      my $longest_pathname = longest(@{ $this->{display_debs} });
      
      # Create widgets
      my $newt = $this->{newt};
      $$newt{main} = Newt::Panel(1,3, gettext("Reading changelogs"));
      $$newt{progress} = Newt::Scale($screen_width - 10, scalar(@debs));
      $$newt{current} = Newt::Label(' ' x length($longest_pathname));
      
      my $main = $$newt{main};
      $main->Add(0, 0, Newt::Label(gettext("Scanning packages...")));
      $main->Add(0, 1, $$newt{progress});
      $main->Add(0, 2, $$newt{current});
      $main->Draw();

      1;
    },
    
    'update_progress' => sub {
      my $this = shift;
      my $display_debs = $this->{display_debs};
      my $display_deb = shift @$display_debs;

      my $newt = $this->{newt};
      # Update progress filename
      $newt->{current}->Set( $display_deb );
      $newt->{progress}->Set( ++$this->{debs_processed} );
    Newt::Refresh();
    },
    
    'display_output' => sub {
      my ($this, $output) = @_;

      my $newt = $this->{newt};
      $newt->{confirm} = 1;

      if ($output) {
	my ($screen_width, $screen_height) = Newt::GetScreenSize();
	
	$$newt{main} = Newt::Panel(1, 2, gettext("Displaying changelogs"));
	$$newt{main}->Add(0, 0, Newt::Textbox($screen_width - 10, $screen_height - 10,
					      &Newt::NEWT_FLAG_WRAP|
					      &Newt::NEWT_FLAG_SCROLL,
					      $output));
	$$newt{main}->Add(0, 1, Newt::Panel(2, 1)
			  ->Add(0, 0, &Newt::OK_BUTTON)
			  ->Add(1, 0, &Newt::CANCEL_BUTTON));
	
	my ($reason, $data) = $$newt{main}->Run();
	if ($reason eq &Newt::NEWT_EXIT_COMPONENT
	    && $data->Tag() eq 'CANCEL') {
	  $newt->{confirm} = 0;
	};
      }
      
      Newt::Finished();
    },

    'confirm' => sub {
      my ($this) = @_;

      $this->{newt}->{confirm};
    }
  };

  $frontends{'pager'} = {
    'init' => sub {
      my ($this) = @_;
      # Set autoflush on stdout
      $| = 1;

      1;
    },
    
    'update_progress' => sub {
      my ($this) = @_;
      
      my $percent = int(++$this->{debs_processed} / scalar(@debs) * 100);

      printf gettext("Reading changelogs...%s") . "\r",
      $percent == 100 ? gettext("Done") : "$percent%";
    },
    
    'display_output' => sub {
      my ($this, $output) = @_;
      
      print "\n";
      return 0 unless $output;

      my $sigpipe_handler = $SIG{'PIPE'} || 'DEFAULT';
      $SIG{'PIPE'} = 'IGNORE';

      open(PAGER, "|$sensible_pager")
	  || die "pager $sensible_pager not found";

      print PAGER $output;

      close(PAGER);

      $SIG{'PIPE'} = $sigpipe_handler;

      0;
    },

    'confirm' => sub {
      my ($this) = @_;

      unless (open(TTY, "+</dev/tty")) {
	warn gettext("Unable to open tty for confirmation, assuming yes")
	    . "\n";
	return 1;
      }

      TTY->autoflush;

      print TTY "apt-listchanges: ",
      gettext("Do you want to continue [Y/n]? ");

      my $response = <TTY>;
      close(TTY);

      return 0 if $response =~ /^[Nn]/;
      return 1;
    }
  };

  $frontends{'xterm-pager'} = {
    'init' => $frontends{pager}->{init},

    'update_progress' => $frontends{pager}->{init},

    'display_output' => sub {
      my ($this, $output) = @_;

      return 0 unless $output;

      my $tempfile = `tempfile`;
      chomp($tempfile);

      if (!open(TEMPFILE, ">$tempfile")) {
	warn "apt-listchanges: "
	    . sprintf(gettext("Unable to open temporary file %s: %s"),
		      $tempfile, $!) . "\n";
	return undef;
      }

      print TEMPFILE $output;
      close(TEMPFILE);

      if (!fork) {
	setpgrp();
	chdir("/");
	open(DEVNULL, "<+/dev/null");
	select(DEVNULL); # Avoid a warning from -w
	open(STDIN, "<&DEVNULL");
	open(STDOUT, ">&DEVNULL");
	open(STDERR, ">&DEVNULL");

	# We should do TIOCNOTTY here, but Perl doesn't seem to give
	# us its value

	system('x-terminal-emulator', '-e', 'sensible-pager', $tempfile);
	unlink($tempfile);

	exit(0);
      }

      1;
    },

    'confirm' => $frontends{pager}->{confirm}
  };
      
  
  $frontends{'text'} = {
    'init' => sub { print "Reading changelogs...\n"; STDOUT->flush; },
    
    'update_progress' => sub {},
    
    'display_output' => sub {
      my ($this, $output) = @_;
      
      print "\n", $output;
      0;
    },

    'confirm' => $frontends{pager}->{confirm}

  };

  $frontends{'mail'} = {

    'init' => $config{'quiet'} ? $frontends{text}->{init} :
	$frontends{pager}->{init},

    'update_progress' => $config{'quiet'} ?
	$frontends{text}->{update_progress}
    : $frontends{pager}->{update_progress},

    'display_output' => sub {
      my ($this, $output) = @_;

      print "\n";

      return 0 unless $output;

      my $host = hostname;

      open(MAIL, "|/usr/lib/sendmail -t") || die "sendmail: $!\n";
      print MAIL <<EOT;
To: $email_address
Subject: apt-listchanges output for $host

EOT
    print MAIL $output;
      close(MAIL);

      print sprintf(gettext("Changelogs mailed to %s"), $email_address), "\n";
      $? >> 8;
    },

    'confirm' => sub { 1; }

  };

  my $frontend = $frontends{$frontend_opt};
  die "Unknown frontend: $frontend_opt\n" unless defined $frontend;
    
  ## Common stuff for all frontends
  
  # Strip pathnames
  my @display_debs = @debs;
  @display_debs = map { m%([^/]+)$%; $1; } @display_debs;
  $frontend->{display_debs} = \@display_debs;

  # Initialize the frontend
  while (!&{ $frontend->{init} }($frontend)) {
    # Initialization failed, fall back
    my $new_frontend;
    
    if ($frontend eq $frontends{'newt'}) {
      $new_frontend = 'pager';
    } elsif ($frontend eq $frontends{'pager'}) {
      $new_frontend = 'mail';
    } elsif ($frontend eq $frontends{'mail'}) {
      $new_frontend = 'text';
    } elsif ($frontend eq $frontends{'text'}) {
      die "apt-listchanges: Unable to initialize text frontend!  Giving up.\n";
    }

    warn "apt-listchanges: Falling back to $new_frontend frontend\n";
    $frontend = $frontends{$new_frontend};
  }
    
  $frontend;
}

# Find the longest scalar in an array
sub longest {
  my $max;

  foreach my $x (@_) {
    $max = $x if !defined($max) || length($x) > length($max);
  }

  $max;
}

sub read_deb_filenames {
  my ($apt_mode, $status) = @_;
  my %debs;
  my @order;

  if ($apt_mode) {

    my $peek = <STDIN>;
    chomp($peek);

    if ($peek eq "VERSION 2") {
      while (<STDIN>) {
	if (2 .. /^$/) {
	  # APT configuration data

	  /^quiet=(\d+)/ && do { $config{'quiet'} = $1; };

	} else {

	  next unless my ($pkg, $oldversion, $newversion, $filename)
	      = /^(\S+)\s+(\S+)\s+<\s+(\S+)\s+(\S+)$/;
	  next if $oldversion eq '-';

	  if ($filename =~ /^\*\*(.+)\*\*$/) {
	    if ($1 eq 'CONFIGURE') {
	      push(@order, $pkg);
	    }
	    next;
	  }

	  $debs{$pkg} = $filename;
	  $status{$pkg}{Version} = $oldversion;
	  $status{$pkg}{NewVersion} = $newversion; # Not used yet
	}
      }
    } else {
      warn "apt-listchanges: " . gettext("Wrong or missing VERSION from apt pipeline");
      warn gettext("(is Dpkg::Tools::Options::/usr/bin/apt-listchanges::Version set to 2?)") . "\n";
      exit 1;
    }

  } else {
    # Not in apt mode, use filenames from the command line
    return @ARGV;
  }

  # Sort by configuration order
  my @ret;
  foreach (@order) {
    if (defined $debs{$_}) {
      push(@ret, $debs{$_});
    }
  }
  @ret;
}


sub read_rpm_filenames {
  my ($apt_mode, $status) = @_;
  my %debs;
  my $peek;

  if ($apt_mode) {

    while ($peek = <STDIN>) {
      ($peek =~ /^\s*$/) && next;
      chomp($peek);
      my ($pkg, $newversion, $oldversion, $sourcepackage, $lastchange) = rpm_get_package_info ($peek, \%status);
      my $filename = $peek;

      $debs{$pkg} = $filename;
      $status{$pkg}{Version} = $oldversion;
      $status{$pkg}{NewVersion} = $newversion; # Not used yet

    }
  } else {
    # Not in apt mode, use filenames from the command line
    return @ARGV;
  }

  values (%debs);
}


# Simple-minded config file parser
sub read_config {
  my ($config_file, $config) = @_;

  open(CONF, $config_file) || return undef;
  while (<CONF>) {
    next if /^#/;
    my ($name, $value);
    if ( ($name, $value) = /^\s*([^=\s]+)\s*=\s*(\S*)\s*$/ ) {
      $$config{$name} = $value;
    }
  }
  close(CONF);
}


sub min {
  my ($a, $b) = @_;

  $a < $b ? $a : $b;
}

##
## All the rest of this stuff should be replaced by a good set of Perl
## bindings for apt (or maybe I should reimplement this in Python)
##

# Extract the package name and version from a .deb file
sub get_package_info {
  my ($deb, $status) = @_;

  my ($pkg, $version, $source);

  open(DPKGDEB, "dpkg-deb -f $deb Package Version Source 2>&1|") || die;
  while (<DPKGDEB>) {
    chomp;
    /^Package: (.*)$/ && do { $pkg = $1 };
    /^Version: (.*)$/ && do { $version = $1 };
    /^Source: (.*)$/ && do { $source = $1 };
  }
  close(DPKGDEB);

  # Bail quickly if it wasn't even a .deb
  return unless defined $pkg && defined $version;

  # If no source package is specified, source package has the same
  # name as the binary package
  $source ||= $pkg;

  # Look up installed version of $pkg, using the source package
  # version if different
  my $oldversion = $$status{$pkg}{Version};
  if ($$status{$pkg}{Source}
      && $$status{$pkg}{Source} =~ /\((.*)\)/) {
    $oldversion = $1;
  }

  # Check for different source package version for the deb
  if ($source =~ /\((.*)\)/) {
    $version = $1;
    $source =~ s/\s*\(.*\)//;
  }

  ($pkg, $version, $oldversion, $source);
}

# Extract the package name and version from a .rpm file
sub rpm_get_package_info {
  my ($rpm, $status) = @_;

  my ($pkg, $version, $oldversion, $source, $lastchange);

  open(RPM, "rpm -qp --queryformat "
    . "\"%{NAME} %{EPOCH}:%{VERSION}-%{RELEASE}\\n\" $rpm|") || die;
  chomp ($_ = <RPM>);
  ($pkg, $version) = split;
  $version =~ s/\(none\)://;
  close(RPM);

  $source ||= $pkg;

  # Look up installed version of $pkg
  $oldversion = $$status{$pkg}{Version};
  if ($$status{$pkg}{Source}
      && $$status{$pkg}{Source} =~ /\((.*)\)/) {
    $oldversion = $1;
  }

  # Check for different source package version
  #if ($source =~ /\((.*)\)/) {
  #  $oldversion = $1;
    $lastchange = $status{$pkg}{LastChange};
    $source =~ s/\s*\(.*\)//;
  #}

  ($pkg, $version, $oldversion, $source, $lastchange);
}

# Read in package names and versions from the status file and store
# them in the hash ref $status
sub deb_read_status {
  my ($status) = @_;

  my $statusfile = "/var/lib/dpkg/status";

  open(STATUS, $statusfile) || die "$statusfile: $!\n";
  my $pkg;
  while (<STATUS>) {
    /^Package: (.*)$/o && do { $pkg = $1 };
    /^Version: (.*)$/o && do { $$status{$pkg}{Version} = $1 };
    /^Source: (.*)$/o && do  { $$status{$pkg}{Source} = $1; }
  }
  close(STATUS);
}

sub rpm_read_status {
  my ($status) = @_;

  open(STATUS, "rpm -qa --queryformat "
    . "\"Package: %{NAME}\\nVersion: %{EPOCH}:%{VERSION}-%{RELEASE}\\n"
    . "Source: %{SOURCERPM}\\n\" --changelog|") || die;
  my $pkg;
  my $newpkg = 1;
  while (<STATUS>) {
    chomp; /^\s*$/ && next;
    /^Package: (.*)$/o && do { $pkg = $1; $newpkg = 1; next; };
    if ($newpkg) {
      /^Version: (.*)$/o && do { $$status{$pkg}{Version} = $1; next; };
      /^Source: (.*)$/o && do { $$status{$pkg}{Source} = $1; next; };
      /^\* (.*)$/o && do { $$status{$pkg}{LastChange} = $1; $newpkg = 0; };
      $$status{$pkg}{Version} =~ s/\(none\):/0/;
    }
  }
  close(STATUS);
}

sub dpkg_compare_versions {
  my ($a, $op, $b) = @_;

  my @cmd = ('dpkg', '--compare-versions', $a, $op, $b);
  my $ret = system(@cmd);
  $ret <<= 8;

  $ret == 0;
}

# rpmver return codes:
#          1 - Version1 is newer
#          0 - Versions are equal
#         -1 - Version2 is newer
#         -2 - rpmver version and copyright info returned
#         -3 - Paramter error, returning usage info
#         -4 - Version too long error
# 
#         -5 - For some reason, you enter version-release for one string only
#              I'm sure you only mistyped it. Try again.
# 
sub rpm_compare_versions {
  my ($a, $op, $b) = @_;

  # add epoch 0 if no epoch is set
  $a = "0:$a" unless ($a =~ /:/);
  $b = "0:$b" unless ($b =~ /:/);

  my @cmd = ("rpmver $a $b >/dev/null");
  my $ret = system(@cmd) >> 8;
  ($ret > 127) && ($ret -= 256);
  ($ret < -1) && die;
 
  ($op eq 'lt') && ($ret = !($ret < 0));
  ($op eq 'le') && ($ret = !($ret < 1));
  ($op eq 'gt') && ($ret = !($ret > 0));
  ($op eq 'ge') && ($ret = !($ret > -1));
  ($op eq 'eq') && ($ret = !($ret == 0));
  ($op eq 'lt') && ($ret = !($ret != 0));

  $ret == 0;
}
