#!/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.6 2006/02/23 01:55:13 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 %field
  = ( size              => { column  => 0,
                             sort    => 1,
                             numeric => 1,
                             fmt     => \&fmtsize,
                           },
      name              => { column  => 1,
                             sort    => 0,
                           },
      'version-release' => { column  => 2,
                             sort    => 2,
                           },
      arch              => { column  => 3,
                             sort    => 3,
                           },
      installtime       => { column  => 4,
                             sort    => 4,
                             numeric => 1,
                             fmt     => \&fmtdate,
                           },
    );

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

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 fielderr
{
  print join (": ", $progname, @_), "\n",
        "Valid field names are:\n\t",
        join ("\n\t", fieldnames()), "\n";
  exit (1);
}

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 cmd
{
  my (@cmd) = @_;

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

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

  my @field = fieldnames ();
  map { s/([a-z0-9:]+)/%{$1}/gi } @field;

  my $fmt = join ("|", @field) . "\n";
  my @cmd = (qw(rpm --nodigest --nosignature),
             ("@_" =~ /\*/ ? '-qa' : '-q'),
             '--qf', $fmt, @_);
  #print STDERR "$progname: @cmd\n";
  my $fh = cmd (@cmd);

  $_ = <$fh>;
  s/^package .*? is not installed\n//gm;
  my @lines = map { [split (/\|/, $_)] } split (/\n/, $_);
  close ($fh);

  return \@lines;
}

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

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

  my @field = (@$sortby, fieldnames (%f));
  #print "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 $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 @fn = map { $field{$_}->{fmt} } fieldnames ();
  my @width = (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: