#!/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.53 2019/08/05 11:30:34 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;
my $show_total;
my $total = 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 $datefmt = $ENV{DATEFMT} || '%Y-%m-%d %H:%M:%S' ;

my %repo_fingerprint;

sub xopen
{
  my $file = $_[0];
  return unless -f $file;

  open (my $fh, $file);
  return $fh if $fh;

  print STDERR "open: $file: $!\n";
  return;
}

sub repo_fingerprint_init
{
  my $fh = @_ ? xopen ($_[0]) : q(main::DATA);
  return unless $fh;

  while (<$fh>)
    {
      s/\s*#.*//;
      $repo_fingerprint{$1} = $2 if m/^\s*(\S+)\s+(\S+)/;
    }
  close ($fh);
}

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
{
  return "" if $_[0] eq "";
  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 ();
  my @lines = map { my @f = split (/\x1/, $_);
                    $total += $f[0];
                    if (@prefmt)
                      {
                        for (my $i = 0; $i < @f; $i++)
                          {
                            my $fn = $prefmt[$i];
                            $f[$i] = &$fn ($f[$i]) if $fn;
                          }
                      }
                    \@f;
                  } split (/\n/, $_);

  push @lines, [$total, "TOTAL", ("") x ((scalar keys %field) - 2)]
    if $show_total;
  return \@lines;
}

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] },
              "t|total",          \$show_total);

  $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;

  my $rc = $ENV{RPMFINGERPRINTS} || "$ENV{HOME}/.rpm-fingerprints";
  repo_fingerprint_init ();    # data section
  repo_fingerprint_init ($rc); # user config

  printlines (fmtlines (sortlines (rpmq (@ARGV))));
}

main ();

__DATA__

######
## GPG key fingerprints for RPM signatures
######

cfc659b9	fedora-30
429476b4	fedora-29
9db62fb1	fedora-28
f5282ee4	fedora-27
64dab85d	fedora-26
bfb2d6e3	fedora-26-neverused
fdb19c98	fedora-25
81b46521	fedora-24
34ec9cba	fedora-23
8e1431d5	fedora-22
95a43f54	fedora-21
246110c1	fedora-20
fb4b18e6	fedora-19
de7f38bd	fedora-18
1aca3465	fedora-17
a82ba4b7	fedora-16
069c8460	fedora-15
97a1071f	fedora-14
e8e40fde	fedora-13
57bbccba	fedora-12
d22e77f2	fedora-11
4ebfc273	fedora-10
6df2196f	fedora-8/9	# only used for fedora 8/9 updates
df9b0ae9	fedora-8/9-test

# No secondary keys after Fedora 26
3b921d09	fedora-26-secondary
e372e838	fedora-25-secondary
030d5aed	fedora-24-secondary
873529b8	fedora-23-secondary
a29cb19c	fedora-22-secondary
a0a7badb	fedora-21-secondary
efe550f5	fedora-20-secondary
ba094068	fedora-19-secondary
a4d647e9	fedora-18-secondary
f8df67e6	fedora-17-secondary
10d90a9e	fedora-16-secondary
3ad31d0b	fedora-15-sparc
19be0bf9	fedora-14-secondary
fdb36b03	fedora-14-s390x
5bf71b5e	fedora-13-sparc
f613cbe8	fedora-9/10/11-ia64
00458545	fedora-9-sparc

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

fd431d51	rhel-6

c0aeda6e	rpmfusion-free-f30
42f19ed0	rpmfusion-free-f29
09eab3f2	rpmfusion-free-f28
7d838377	rpmfusion-free-f27
9690e4af	rpmfusion-free-f26
6806a9cb	rpmfusion-free-f25
b7546f06	rpmfusion-free-f24
e051b67e	rpmfusion-free-f23
97f4d1c1	rpmfusion-free-f22
6446d859	rpmfusion-free-f21
ae688223	rpmfusion-free-f20
172ff33d	rpmfusion-free-f19
982e0a7c	rpmfusion-free-f18
8296fa0f	rpmfusion-free-f17
adf25d9c	rpmfusion-free-f16
00a4d52b	rpmfusion-free-f15
865cc9ea	rpmfusion-free-f14
a3780952	rpmfusion-free-f13
16ca1a56	rpmfusion-free-f12
8fcff4da	rpmfusion-free-f11
49c8885a	rpmfusion-free-f10-or-earlier

1d14a795	rpmfusion-nonfree-f30
d6841af8	rpmfusion-nonfree-f29
7f858107	rpmfusion-nonfree-f28
b9c13282	rpmfusion-nonfree-f27
3276f4b3	rpmfusion-nonfree-f26
fa7a179a	rpmfusion-nonfree-f25
96ca6280	rpmfusion-nonfree-f24
5ca6c469	rpmfusion-nonfree-f23
a6708da3	rpmfusion-nonfree-f22
a668b376	rpmfusion-nonfree-f21
b5f29883	rpmfusion-nonfree-f20
cd30c86b	rpmfusion-nonfree-f19
e31b30ca	rpmfusion-nonfree-f18
d2382b83	rpmfusion-nonfree-f17
952f3af8	rpmfusion-nonfree-f16
6d0c8ec2	rpmfusion-nonfree-f15
f09d8368	rpmfusion-nonfree-f14
2425b284	rpmfusion-nonfree-f13
a3a882c1	rpmfusion-nonfree-f12
8dc43844	rpmfusion-nonfree-f11
b1981b68	rpmfusion-nonfree-f10-or-earlier

849c449f	rpmfusion-free-el6
e74f0522	rpmfusion-free-el5

5568bbb2	rpmfusion-nonfree-el6
ab194290	rpmfusion-nonfree-el5

f4a80eb5	centos-7
c105b9de	centos-6
e8562897	centos-5
443e1821	centos-4

fe837f6f	centos-security-6

# CentOS SoftwareCollections SIG (https://wiki.centos.org/SpecialInterestGroup/SCLo
f2ee9d55	centos-sc

3dbdc284	opensuse

39db7c82	suse-sles-12.0
50a3dd1c	suse-sles-12.0-reserve

307e3d54	suse-sles-11.2
b37b98a9        suse-sles-11.2-ptf

9c800aca	suse
3d25d3d9	suse-security

f14ab620	zfsonlinux.org
f6777c67	adobe
66534c2b	atrpms
6b8d79e6	dag
1aa78495	dries
e42d547b	freshrpms
7fac5991	google
ff6382fa	kde-redhat
a109b1ec	livna
22b2951d	mhensler-suspend2
be1229cf	microsoft
f90c0e97	negativo17
98ab5139	oracle-virtualbox
a9464aa9	pidgin
ba392878	splode-internal-2005	# internal reference key; not secure
dbcccc4b	splode-internal-2015	# internal reference key; not secure

d59097ab	ops@packagecloud.io
038651bd	slack@packagecloud.io
bf6a7041	slack.com

598252fb	rockowitz@build.opensuse.org

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

(none)  	(unknown)	# unsigned so dont know what repo it came from

# eof