#!/usr/bin/perl
### ckpacklist.perl  -*- Perl -*-
## Check list of installed packages against user-specified categories.

### Ivan Shmakov, 2018, 2020, 2021

## To the extent possible under law, the author(s) have dedicated
## all copyright and related and neighboring rights to this software
## to the public domain worldwide.  This software is distributed
## without any warranty.

## You should have received a copy of the CC0 Public Domain Dedication
## along with this software.  If not, see
## <http://creativecommons.org/publicdomain/zero/1.0/>.

### History:

## 0.7  2021-07-31 06:30Z
##      New --omit=TAG option.
##      (@omit, %omit): New package-global variables.
##      (omit_p): Likewise.
##      (parse_line_ini): Omit the category if any of the tags is
##      in %omit.
##      (parse_rfc_fin): Likewise.
##      (parse_rfc_fin_1): New function, split off
##      (parse_rfc_fin): here.

## 0.6  2021-07-30 19:20Z
##      (parse_rfc_prep): Fixed: trim whitespace for all the lines
##      processed (was: only the initial value passed to the function.)
##      (parse_line_rfc2822): Fixed: finalize header on an empty line
##      (was: any non-continuation line.)

## 0.5  2021-07-29 19:20:19Z
##      (sfn.MVobif8SMm1FWRDmr77ghuIsgpZcLvSwhxQH4IdTQvA.perl)
##      Added support for the RFC 2822-based variant of the category
##      file format.  Skip over optional RFC 2822-style file header.
##      Canonicalize intersection category names to the first variant
##      seen.  Avoid grep entirely on --no-include in two instances
##      (were: passed empty lists.)
##      (%canon): New variable.
##      (canon_cat): New function.
##      (parse_line_ini): New function, adapted from former main loop
##      body.  Use chomp (was: relying on $ matching a trailing \n.)
##      (%parse_rfc, $parse_line_add, $parse_line): New variables.
##      (parse_rfc_fin): New function.
##      (parse_rfc_prep): Likewise.
##      (parse_line_rfc2822): Likewise.
##      (parse_line_auto): Likewise.
##      (parse_line_maybe_skip_header): Likewise.

## 0.4  2020-10-08 14:35:26Z
##      (sfn.aYPDnXKXUI27GOXWPWgktkBlGGH3mmVeX4v9Tpr8V9c.perl)
##      New --[no-]include option.  Show state of all binary options
##      with --debug.

## 0.3  2020-07-15 16:15:13Z
##      (sfn.F8OaiuhTBKng3mSNdNTDWJ6A06VY229ilqeOKpRCOu4.perl)
##      Fixed: ignore trailing whitespace in package list
##      (i. e. install, recommend, suggest) lines.
##      ($example): Fixed: use recommend (was: recommends.)

## 0.2  2020-07-08 21:17:23Z
##      (sfn.FzmFOgpQGai856pxcMOyGUfudU0-1HUBdOtIqTTg_S0.perl)
##      New --[no-]debug, --[no-]empty and -u, --unknown[=NAME] options.
##      Fixed: use safer (but newer) <<>> (was: <>.)  Use Getopt::Long.

## 0.1  2018-07-04 16:10:17Z
##      (sfn.LxRflngGh5jBP-af4VVV-MbnLA3XDy7IW5YlPFopHJY.perl)
##      Initial revision.

### Code:

use common::sense;
use English qw (-no_match_vars);

# require Data::Dump;
require Getopt::Long;
require List::Util;

our ($usage, $example) = (qq {Usage:
    \$ ${0} [--[no-]debug] [--[no-]empty] [--[no-]include
          [--omit=NAME]... [-u|--unknown[=NAME]] [-v|--verbose]
          [--] CATEGORIES.LIST [PACKAGES.LIST]...
    \$ ${0} -h|--help
}, qq {Example:

bash\$ ${0} example.com-cf/categories.list \\
          <(apt-mark showmanual) | sort -n | less -F 
-4	11	network	dns-root-data idn netbase sic
-10	74	base	apg ca-cacert file libencode-locale-perl
 libtasn1-bin libterm-readline-gnu-perl lynx lzop minilzip pdlzip
bash\$ 

CATEGORIES.LIST should be formatted as per the following example.

;;; cats.list
[base]
recommend = apg lynx pdlzip
[network]
recommend = dns-root-data socat
[bittorrent]
recommend = aria2 rhash
include = network
;;; cats.list ends here

Note that the apt-mark(1) command can also be executed via SSH
(like: ssh -- REMOTE apt-mark), or for a system installed under
a specific directory (such as a chroot environment), like:

    (d=/other/rootdir ; apt-mark -o Dir="\$d" \\
         -o Dir::State::status="\$d"/var/lib/dpkg/status)

});

Getopt::Long::Configure (qw (gnu_getopt));

our ($debug_p, $empty_p, $include_p, $verbose_p)
    = (0, 1, 1, 0);
our ($unknown, @omit)
    = ();

my %cmdline_options =  (q (debug!)      => \$debug_p,
                        q (empty!)      => \$empty_p,
                        q (include!)    => \$include_p,
                        q (omit=s)      => \@omit,
                        q (v|verbose!)  => \$verbose_p,
                        q (u|unknown:s) => \$unknown,
                        q (h|help)
                        => sub { print ($usage, "\n", $example); exit (0); });

my $parsable_p
    = Getopt::Long::GetOptions (%cmdline_options)
    or die ("Cannot parse command line arguments");

if (@ARGV < 1) {
    print STDERR ($usage);
    ## .
    exit (1);
}

my $no
    = sub { $_[0] ? "" : "no-"; };
warn (sprintf  ("D: --debug --%sempty --%sinclude --%sverbose are in effect",
                $no->($empty_p), $no->($include_p), $no->($verbose_p)))
    if ($debug_p);

our @ucats   = (! defined ($unknown) ? ()
                : "" eq $unknown ? ("(unknown)")
                : ($unknown));
warn ("D: --unknown=", $ucats[0], " in effect")
    if ($debug_p && @ucats);

warn ("D: ", join (" ", map { "--omit=" . $_ } (@omit)), " in effect")
    if ($debug_p && @omit);

my (%cat, %implies);

my $cf
    = shift (@ARGV);
open (my $ch, "<", $cf)
    or die ($cf, ": Cannot open categories file: ", $!);

my %canon;

sub canon_cat
{
    my ($c) = @_;
    ## .
    return $c
        unless (index ($c, "+") > 0);
    ## .
    return $canon{$c}
        if (exists ($canon{$c}));

    my $alt
        = join ("+", sort { $a cmp $b; } (split (/\++/, $c)));

    ## .
    $canon{$c}
        = ($canon{$alt} //= $c);
}

our %omit;

@omit{@omit}
    = ();

sub omit_p
{
    my ($c) = @_;
    our %omit;

    use List::Util qw (any);
    ## .
    return 1
        if (any { exists ($omit{$_}); } (split (/\+/, $c)));

    ## .
    return 0;
}

## Read the categories.
my $cc;

sub parse_line_ini
{
    chomp ();

    ## .
    return
        if (m { ^ \s* (?: $ | ;) }x);

    ## Parse [CATEGORY] headers.
    if (my ($newc) = m { ^ \s* \[ (\S*) \] $ }x) {
        $cc = $newc;
        ## .
        return;
    }

    ## .
    my ($k, $v) = m {
        ^ \s* (include | install | recommend | suggest)
        \s* = \s* (.* \S)? \s* $
    }x  or return;
    return
        if (omit_p ($cc) || ! $include_p && $k eq "include");
    my $h
        = ($k eq "include" ? \%implies : \%cat);
    $cc = canon_cat ($cc);
    $h->{$cc} = { }
        unless (exists ($h->{$cc}));
    @{$h->{$cc}}{split (/\s+/, $v)}
        = ();
}

my %parse_rfc;

sub parse_rfc_fin_1
{
    $cc = canon_cat ($cc);
    foreach my $sh ([ $parse_rfc{"packages"}, \%cat ],
                    [ $parse_rfc{"implies"},  \%implies ]) {
        my ($set, $h)
            = @$sh;
        next
            unless (defined ($set));
        $h->{$cc} = { }
            unless (exists ($h->{$cc}));
        @{$h->{$cc}}{keys (%$set)}
            = ();
    }
}

sub parse_rfc_fin {
    parse_rfc_fin_1 ()
        unless (omit_p ($cc));
    $cc = "";
    %parse_rfc
        = ();
}

sub parse_rfc_prep
{
    my ($set, $v, $re) = @_;

    my $f = sub {
        ## .
        return parse_rfc_fin ()
            unless (defined ($_));

        ## .
        return
            unless (defined ($set));

        s/^\s+//;
        s/\s+$//;

        ## .
        @{$set}{split ($re)}
            = ();
    };

    ## .
    return $f
        unless (defined ($set));

    local $_
        = $v;
    $f->();

    ## .
    $f;
}

my $parse_line_add
    = undef;

sub parse_line_rfc2822
{
    chomp ();

    ## Parse continuation lines.
    if (! defined ($parse_line_add)) {
        ## do nothing
    } elsif (m {^\s}) {
        ## .
        return $parse_line_add->();
    } else {
        unless (m {.}) {
            local $_;
            $parse_line_add->();
        }
        $parse_line_add
            = undef;
    }

    ## Skip over human-readable text.
    ## .
    return
        if (m { ^(?: \t | \s\s | \s?$) }x);

    ## Parse initial lines.
    my ($tags, $packages, $implies, $unknown) = m {
        ^ (?:   Tags: \s* (.*)
              | Packages: \s* (.*)
              | Implies:  \s* (.*)
              | ([-0-9A-Za-z_]+:))
    }xi;
    if (defined ($unknown)) {
        warn ("D: Unknown header: ", $unknown, "; ignored")
            if ($debug_p);
        $parse_line_add
            = parse_rfc_prep ();
    } elsif (defined ($tags)) {
        $cc = ($tags =~ s/\s+$//r);
        $cc =~ s/\s*,\s*/+/g;
        $parse_line_add = sub {
            ## .
            return parse_rfc_fin ()
                unless (defined ($_));

            $cc .= "+"
                if ($tags ne "");
            s/,\s*/+/g;
            $cc .= $_;
        };
    } elsif (defined ($packages)) {
        $parse_line_add
            = parse_rfc_prep (($parse_rfc{"packages"} //= { }),
                              $packages, qr {\s+});
    } elsif (defined ($implies)) {
        $parse_line_add
            =  (! $include_p ? parse_rfc_prep ()
                : parse_rfc_prep (($parse_rfc{"implies"} //= { }),
                                  $implies, qr {\s*,\s*}));
    } else {
        warn ("Warning: Cannot parse line: ", $_, "; ignored");
    }
}

my $parse_line;

sub parse_line_auto
{
    ## NB: $ matches "" and "\n" alike
    my ($empty_p, $space_p, $ini_p, $rfc_p) = m {
        ^ (?:   ()$
              | (\s)
              | ([[;])
	      | ([-0-9A-Za-z_]+:))
    }x;

    if (defined ($ini_p)) {
        warn ("D: Ini-style file format detected")
            if ($debug_p);
        ## .
        return ($parse_line = \&parse_line_ini)->();
    } elsif (defined ($rfc_p)) {
        warn ("D: RFC 2822-style file format detected")
            if ($debug_p);
        ## .
        return ($parse_line = \&parse_line_rfc2822)->();
    } elsif (defined ($empty_p) || defined ($space_p)) {
        ## do nothing
    } else {
        chomp ();
        warn ("Warning: Cannot parse line: ", $_, "; ignored");
    }
}

sub parse_line_maybe_skip_header
{
    unless (m {^[-0-9A-Za-z_]+:}) {
        ## .
        return ($parse_line = \&parse_line_auto)->();
    }

    warn ("D: RFC 2822-style file header detected; skipping")
        if ($debug_p);
    ## .
    $parse_line = sub {
        ## .
        return
            if (m {.});
        $parse_line
            = \&parse_line_auto;
    };
}

$parse_line
    = \&parse_line_maybe_skip_header;

$parse_line->()
    while (<$ch>);

## Categories of the form foo+bar entail foo, bar.
foreach my $c (! $include_p ? () : grep { /\+/; } (keys (%cat))) {
    $implies{$c} = { }
        unless (exists ($implies{$c}));
    my @a
        = split (/\+/, $c);
    @{$implies{$c}}{@a}
        = ();
}

## Inclusion is transitive.
foreach my $c ($include_p ? keys (%implies) : ()) {
    my $g
        = $implies{$c};
    my @recurse
        = keys (%$g);
    foreach my $d (@recurse) {
        my $h
            = $implies{$d};
        my @a
            = grep { ! exists ($g->{$_}); } (keys (%$h));
        @{$g}{@a}
            = ();
        push (@recurse, @a);
    }
    warn ("D: ", $c, ": Category entails: ", join (", ", keys (%$g)))
        if ($debug_p);
}

## Map packages back to categories.
my %pkg;
foreach my $c (keys (%cat)) {
    foreach my $p (keys (%{$cat{$c}})) {
        $pkg{$p} = [ ]
            unless (exists ($pkg{$p}));
        push (@{$pkg{$p}}, $c);
    }
}

## Compute the lists of missing packages.
my (%miss, %show_cat);
while (<<>>) {
    ## .
    next
        if (m { ^ \s* (?: $ | ;) }x);

    foreach my $p (split ()) {
        unless (exists ($pkg{$p})) {
            if (@ucats > 0) {
                my ($c)
                    = @ucats;
                warn ("D: ", $p, ": Unknown package; put under ", $c)
                    if ($debug_p);
                @{$cat{$c}}{($p)}
                    = ();
            }
            ## .
            next;
        }

        my $pcats
            = $pkg{$p};
        foreach my $c (@$pcats) {
            @{$miss{$c}}{keys (%{$cat{$c}})} = ()
                unless (exists ($miss{$c}));
            delete ($miss{$c}->{$p});

            my @a
                = split (/\+/, $c);
            @show_cat{@a}
                = ();
            foreach my $d  (exists ($implies{$c})
                            ? keys (%{$implies{$c}}) : ()) {
                @show_cat{($d)}
                    = ();
            }
        }
    }
}

## Include also categories that are intersections of the shown ones.
warn ("D: Ought to show at least: ", join (", ", keys (%show_cat)))
    if ($debug_p);
foreach my $c (! $include_p ? () : grep { /\+/; } (keys (%cat))) {
    my @a
        = split (/\+/, $c);
    use List::Util qw (all);
    next
        unless (all { exists ($show_cat{$_}); } (@a));
    $show_cat{($c)}
        = ();
    warn ("D: Showing category ", $c, " as an intersection of shown ones")
        if ($debug_p);
}

## Output the results.
foreach my $c (keys (%cat)) {
    my @all
        = keys (%{$cat{$c}});
    my ($n, @pa)
        = ((@ucats > 0 && $c eq $ucats[0])
           ? (0,
              $verbose_p ? map { $_ . "+"; } (@all) : @all)
           : ! exists ($miss{$c})
           ? (scalar (@all),
              $verbose_p ? map { $_ . "-"; } (@all) : @all)
           : (scalar (keys (%{$miss{$c}})),
              $verbose_p
              ? map { exists ($miss{$c}->{$_}) ? $_ . "-" : $_ } (@all)
              : keys (%{$miss{$c}})));
    warn ("D: ", $c, ": ",
          join (", ", scalar (@pa), $empty_p, $n, scalar (@all), $show_cat{$c}))
        if ($debug_p);
    ## .
    next
        unless (@pa > 0);
    next
        unless ($empty_p || $n != @all || exists ($show_cat{$c}));
    print (- $n, "\t", scalar (@all), "\t", $c,
           "\t", join (" ", sort { $a cmp $b } (@pa)), "\n");
}

### Emacs trailer
## Local variables:
## coding: us-ascii
## indent-tabs-mode: nil
## ispell-local-dictionary: "american"
## End:
### ckpacklist.perl ends here