#!/usr/bin/env perl
# rpm-pkg-list --- summarize installed rpm packages
# Author: Noah Friedman <friedman@splode.com>
# Created: 2004-11-29
# Public domain

# $Id: rpm-pkg-list,v 1.18 2010/02/08 19:12:44 friedman Exp $

# Commentary:
# Code:

$^W = 1; # enable warnings

use strict;
use POSIX;
use Symbol;
use Getopt::Long;

my $sortby = [];
my $reverse_sort;
my $header;
my $progname;
my $fmtsize = 0;

# Meaning of fields:
#  * column  - column number in output.
#  * sort    - default sort precedence.
#  * numeric - sort column numerically rather than lexicographically.
#  * fmt     - pretty-print result; colummn width is computed based on this, but not necessarily sorting.
#  * prefmt  - filter result, before sorting occurs; result might be transformed again by fmt function.
#  * qf      - actual query format string for rpm -q command corresponding to field name.
my %field
  = ( size              => { column  => 0,
                             sort    => 1,
                             numeric => 1,
                             fmt     => \&fmtsize,
                           },
      name              => { column  => 1,
                             sort    => 0,
                             compare => \&cmp_hyphenated_fields,
                           },
      'version-release' => { column  => 2,
                             sort    => 2,
                             compare => \&cmp_version_release,
                           },
      arch              => { column  => 3,
                             sort    => 3,
                           },
      installtime       => { column  => 4,
                             sort    => 4,
                             numeric => 1,
                             fmt     => \&fmtdate,
                           },

      repository        => { column  => 5,
                             sort    => 5,
                             prefmt  => \&fmtrepo,
                             qf      => join (":",
                                              '%|dsaheader?{%{dsaheader:pgpsig}}',
                                              '{%|rsaheader?{%{rsaheader:pgpsig}}',
                                              '{%|siggpg?{%{siggpg:pgpsig}}',
                                              '{%|sigpgp?{%{sigpgp:pgpsig}}',
                                              '{(none)}|}|}|}|',
                                             ),
                           },
    );

my %field_alias
  = ( date        => q(installtime),      time      => q(installtime),
      installdate => q(installtime),      installed => q(installtime),
      version     => q(version-release),  ver       => q(version-release),
      release     => q(version-release),  rel       => q(version-release),
      package     => q(name),             pkg       => q(name),
      repo        => q(repository),       depot     => q(repository),
    );

my %repo_fingerprint
  = (
      '57bbccba' => 'fedora-12',
      'd22e77f2' => 'fedora-11',
      '4ebfc273' => 'fedora-10',
      '6df2196f' => 'fedora-8or9',  # only used for fedora 8/9 updates
      'df9b0ae9' => 'fedora-8or9-test',

      # These fedora keys are discontinued as of 9/2008
      '4f2a6fd2' => 'fedora-core',
      '1ac70ce6' => 'fedora-extras',
      '30c9ecf8' => 'fedora-test',
      '1cddbca9' => 'fedora-rawhide',
      '731002fa' => 'fedora-legacy',

      '16ca1a56' => 'rpmfusion-free-f12',
      '8fcff4da' => 'rpmfusion-free-f11',    # f11 = fedora 11
      '49c8885a' => 'rpmfusion-free-f10',    # fedora 10 and earlier

      'a3a882c1' => 'rpmfusion-nonfree-f12',
      '8dc43844' => 'rpmfusion-nonfree-f11',
      'b1981b68' => 'rpmfusion-nonfree-f10',

      '9c800aca' => 'SuSE',
      '3d25d3d9' => 'SuSE-security',

      'ba392878' => 'splode-local', # internal reference key; not secure

      'e42d547b' => 'freshrpms',
      '66534c2b' => 'atrpms',
      '1aa78495' => 'dries',
      '6b8d79e6' => 'dag',
      'a109b1ec' => 'livna',
      'ff6382fa' => 'kde-redhat',
      '22b2951d' => 'mhensler-suspend2',
      'a9464aa9' => 'pidgin',
      'f6777c67' => 'adobe',

      # Note: these redhat keys should be discontinued as of 9/2008
      'db42a60e' => 'redhat',
      '897da07a' => 'redhat-beta',
      'e418e3aa' => 'redhat-rawhide',

      '(none)'   => '(unknown)',  # unsigned, so dont know what repo it came from
    );

my $datefmt = $ENV{DATEFMT} || '%Y/%m/%d:%H:%M:%S' ;

sub fieldnames
{
  my $f = @_ ? { @_ } : \%field;
  sort { $f->{$a}->{column} <=> $f->{$b}->{column} } keys %$f;
}

sub fieldqf
{
  local $_ = shift;

  return $field{$_}->{qf}
    if exists $field{$_} && $field{$_}->{qf};

  s/([a-z0-9:]+)/%{$1}/gi;
  return $_;
}

sub fielderr
{
  print join (": ", $progname, @_), "\n",
        "Valid field names are:\n\t",
        join ("\n\t", fieldnames()), "\n";
  exit (1);
}

sub field_prefmt_list
{
  my $any = 0;

  my @prefmt = map { my $f = $field{$_}->{prefmt};
                     $any = 1 if $f;
                     $f;
                   } fieldnames ();
  return unless $any;
  return @prefmt if wantarray;
  return \@prefmt;
}

sub capitalize
{
  join ("-", map { ucfirst $_ } split (/-/, $_[0]));
}

sub fmtdate
{
  strftime ($datefmt, localtime ($_[0]));
}

sub fmtsize
{
  return $_[0] unless $fmtsize;

  my $size   = shift;
  my @suffix = ('', qw(K M G T P E));

  while ($size > $fmtsize)
    {
      $size /= $fmtsize;
      shift @suffix;
    }

  my $fmtstr = $size < 100 && $suffix[0] ne '' ? "%.1f%s" : "%d%s" ;
  return sprintf ($fmtstr, $size, $suffix[0]);
}

sub fmtrepo
{
  local $_ = $_[0];
  s/.*Key ID.*(........)$/$1/;
  return $repo_fingerprint{$_} if exists $repo_fingerprint{$_};

  # do a more extensive search and memoize the result so we don't have to
  # search again for other packages with this same key.
  my $try = rpmsigkey ($_);
  if ($try ne '')
    {
      $repo_fingerprint{$_} = $try;
      return $try;
    }
  $repo_fingerprint{$_} = $_;
}


sub cmd
{
  my (@cmd) = @_;

  my $fh = gensym;
  open ($fh, "-|") || exec @cmd;
  return $fh;
}

sub rpmout
{
  local $/ = undef;
  local $_;

  my @cmd = ($ENV{RPMCMD} || 'rpm',
             qw(--nodigest --nosignature),
             ("@_" =~ /\*/ ? '-qa' : '-q'),
             @_);
  #print STDERR "$progname: @cmd\n";
  my $fh = cmd (@cmd);
  $_ = <$fh>;
  close ($fh);
  return $_;
}

sub rpmq
{
  my @qf = map { fieldqf ($_) } fieldnames ();
  my $fmt = join ("\x1", @qf) . "\n";

  local $_ = rpmout ('--qf', $fmt, @_);
  s/^package .*? is not installed\n//gm;

  my @prefmt = field_prefmt_list ();
  if (@prefmt)
    {
      return [map { my @f = split (/\x1/, $_);
                    for (my $i = 0; $i < @f; $i++)
                      {
                        my $fn = $prefmt[$i];
                        $f[$i] = &$fn ($f[$i]) if $fn;
                      }
                    \@f;
                  } split (/\n/, $_)];
    }
  else
    {
      return [map { [split (/\x1/, $_)] } split (/\n/, $_)];
    }
}

sub rpmsigkey
{
  my $fmt = '%{summary}';
  local $_ = rpmout ('--qf', $fmt, '--whatprovides', "gpg($_[0])");
  return "" if /no package provides/;
  s/gpg\(/(/;
  s/\).*/) $_[0]/;
  return $_;
}


# Break down a version string (x.y.z) into individual fields and compare
# each corresponding field.
# For corresponding fields that are both numeric, use `<=>'.
# If either or both are non-numeric, use `cmp'.
# Return [-1,0,1] for the overall comparison.
sub cmp_version
{
  my @a = split (/[.]/, $_[0]);
  my @b = split (/[.]/, $_[1]);
  my $j = (@a < @b ? @a : @b);
  for (my $i = 0; $i < $j; $i++)
    {
      my $cmp = ($a[$i] =~ /^\d+$/ && $b[$i] =~ /^\d+$/
                 ? $a[$i] <=> $b[$i]
                 : $a[$i] cmp $b[$i]);
      return $cmp if $cmp != 0;
    }
  # If all the components up to $j are identical, then the shorter array is
  # 'less' than the larger one.
  return -1 if @a  < @b;
  return  0 if @a == @b;
  return  1 if @a  > @b;
}

# Split string at hyphens and compare each field separately
# according to `cmp_version' (which see).
sub cmp_hyphenated_fields
{
  my $f = defined $_[2] ? $_[2] : 0 ;
  my @a = split (/[-]/, $_[0], $f);
  my @b = split (/[-]/, $_[1], $f);
  my $j = (@a < @b ? @a : @b);
  for (my $i = 0; $i < $j; $i++)
    {
      my $cmp = cmp_version ($a[$i], $b[$i]);
      return $cmp if $cmp != 0;
    }
  return -1 if @a  < @b;
  return  0 if @a == @b;
  return  1 if @a  > @b;
}

# version-release string should only have 2 fields.
sub cmp_version_release
{
  return cmp_hyphenated_fields ($_[0], $_[1], 2);
}

sub sortlines
{
  my ($lines) = @_;

  my %f = %field;
  map { delete $f{$_} } @$sortby;

  my @field = (@$sortby, fieldnames (%f));
  #print STDERR "sortby = ", join (" ", @field), "\n";

  my @sorted = sort
    { my @keys = @field;
      my $res = 0;
      my ($x, $y) = $reverse_sort ? ($b, $a) : ($a, $b);
      while ($res == 0 && @keys)
        {
          my $key = shift @keys;
          my $i = $field{$key}->{column};
          my $cmp = $field{$key}->{compare};
          if ($cmp)
            {
              $res = &$cmp ($x->[$i], $y->[$i]);
            }
          else
            {
              my $np = $field{$key}->{numeric};
              $res = ($np
                      ? $x->[$i] <=> $y->[$i]
                      : $x->[$i] cmp $y->[$i]);
            }
          last if $res;
        }
      $res;
    } @$lines;
  return \@sorted;
}

sub fmtlines
{
  my ($lines) = @_;
  my @fieldnames = fieldnames ();
  my @fn = map { $field{$_}->{fmt} } @fieldnames;
  my @width = ($header
               ? map { length $_ } @fieldnames
               : (0) x @fn);

  map { for (my $i = 0; $i < @fn; $i++)
          {
            my $f = $fn[$i];
            $_->[$i] = &$f ($_->[$i]) if $f;
            $width[$i] = length $_->[$i]
              if length $_->[$i] > $width[$i];
          }
      } @$lines;
  return ($lines, \@width);
}

sub printlines
{
  my ($lines, $width) = @_;
  my @field = fieldnames ();

  my $fmtstr = join ("  ",
                     map { my $w = $width->[$field{$_}->{column}];
                           sprintf ("%%%ds", ($field{$_}->{numeric}
                                              ? $w : -$w));
                         } @field) . "\n";

  printf $fmtstr, map { capitalize ($_) } @field
    if $header;
  map { printf $fmtstr, @$_ } @$lines;
}

sub main
{
  ($progname = $0) =~ s=.*/==;

  Getopt::Long::config ('bundling', 'autoabbrev');
  GetOptions ("d|datefmt=s",      \$datefmt,
              "H|header",         \$header,
              "h|human-readable", sub { $fmtsize = 1024 },
              "si",               sub { $fmtsize = 1000 },
              "r|reverse",        \$reverse_sort,
              "s|sort=s",         sub { push @$sortby, $_[1] });

  $sortby = [qw(name version-release arch)] unless @$sortby;
  $sortby = [map { $field_alias{$_}
                     || (exists $field{$_} && $_)
                     || fielderr ($_, "Unrecognized field name")
                 } map { split (/[\s,]+/, $_) } @$sortby];

  @ARGV = ('*') unless @ARGV;
  printlines (fmtlines (sortlines (rpmq (@ARGV))));
}

main;

# local variables:
# mode: perl
# end: