qdep.pl

#!perl
use strict;
use warnings;


# Usage:  qdep.pl cat/pn   # list of unique atoms that depend ( excluding blockers )
#
# Diagnosing problems:
#
#   DIAGNOSIS=1 qdep.pl cat/pn
#
# Other Useful ENV Vars:
#
#    PDEPEND=1  ( off by default, on with DIAGNOSIS ) query PDEPEND as well
#    BLOCKERS=1 ( off by default, on with DIAGNOSIS ) include blocker lines in output
#    ONLY_BLOCKERS=1 : show only blocker lines in output
#    VERBOSE=1       : don't simplify single-entry explanations in DIAGNOSIS
#    SHOW_ORIG=1     : show original line the decision line was based on in DIAGNOSIS

my ( $name_rx, $version_rx );
{
    my $int_rx        = qr/[0-9]+/;
    my $letter_rx     = qr/[a-zA-Z]/;
    my $dotted_num_rx = qr/$int_rx(?:\.$int_rx)*/o;

    my @suffixes = qw<alpha beta pre rc normal p>;
    my $suffix_rx = join '|', grep !/^normal$/, @suffixes;
    $suffix_rx  = qr/(?:$suffix_rx)/o;
    $version_rx = qr{
   $dotted_num_rx $letter_rx?
   (?:_$suffix_rx$int_rx?)*
   (?:-r$int_rx)?
}xo;
    $name_rx = qr/[a-zA-Z0-9_+-]+?/;
}

use HTTP::Tiny;
use Term::ANSIColor qw( colored );

my $ua      = HTTP::Tiny->new();
my $package = shift @ARGV;

my $opts         = {};
my $explain_opts = {};

if ( $ENV{DIAGNOSIS} ) {
    $opts->{pdepends} = 1;
    $opts->{blockers} = 1;
    $opts->{http_warnings} = 1;
}

$opts->{pdepends}        = $ENV{PDEPENDS} if exists $ENV{PDEPENDS};
$opts->{blockers}        = $ENV{BLOCKERS} if exists $ENV{BLOCKERS};
$opts->{only_blockers}   = 1              if $ENV{ONLY_BLOCKERS};
$explain_opts->{verbose} = 1              if $ENV{VERBOSE};
$explain_opts->{show_orig} = 1            if $ENV{SHOW_ORIG};

my $dependencies = get_dependencies( $package, $opts );

for my $atom ( sort keys %{$dependencies} ) {
    printf "%s\n", $atom;
    print explain( $dependencies->{$atom}, $explain_opts ) if $ENV{DIAGNOSIS};
}

exit;


# get_dependencies( "cat/pn" , { opts } ) 
# 
# returns hash of :
#   
#   { 
#       "cat/pn" => [ { reason }, { reason } ]
#   }
#
sub get_dependencies {
    my ( $package, $opts ) = @_;
    $opts ||= {};
    $opts->{depends}       = 1 unless exists $opts->{depends};
    $opts->{rdepends}      = 1 unless exists $opts->{rdepends};
    $opts->{pdepends}      = 0 unless exists $opts->{pdepends};
    $opts->{blockers}      = 0 unless exists $opts->{blockers};
    $opts->{only_blockers} = 0 unless exists $opts->{only_blockers};

    my $map = {};
    $opts->{depends}
      and $map->{DEPEND} = \&ddeps, $opts->{rdepends}
      and $map->{RDEPEND} = \&rdeps;
    $opts->{pdepends} and $map->{PDEPEND} = \&pdeps;

    my $found = {};

    for my $phase ( sort keys %{$map} ) {
        for my $result ( $map->{$phase}->($package, $opts) ) {
            my $decoded = parse_entry($result);
            next unless defined $decoded;

            if ( $decoded->{is_block} ) {
                next unless $opts->{blockers} or $opts->{only_blockers};
            }
            else {
                next if $opts->{only_blockers};
            }
            push @{ $found->{ $decoded->{package} } },
              { %{$decoded}, phase => $phase };
        }
    }
    return $found;
}

# parse_entry($string)
# 
# Decodes a genrdeps entry into a hash
#
# { 
#     orig      => Original line
#     use       => "use" part of the line from genrdeps
#     is_block  => True if original line had a [B] prefix
#     cat       => Category
#     pn        => Parsed Package Name
#     version   => Parsed Package Version ( or '*' if no version existed for some reason )
#     pacakge   => 'cat/pn' 
# }
sub parse_entry {
    my ($entry) = @_;

    my $result = { orig => "$entry", };

    # slots don't appear in ebuild names and are abused in this format
    # for marking use flags, so nuke them and record it as such
    if ( $entry =~ s/:([^:]+)$// ) {
        $result->{use} = $1;
    }

    # "[B]" appears on the front of an atom if they are "Blockers"
    # remove them from atoms
    if ( $entry =~ s/^\[B\]// ) {
        $result->{is_block} = 1;
    }
    if ( $entry =~ s{^([^/]+)/}{} ) {
        $result->{cat} = $1;
    }
    else {
        warn "No category found in \'$entry\'";
        return;
    }
    if ( $entry =~ m{^($name_rx)(?:-($version_rx))?$}o ) {
        $result->{pn} = $1;
        $result->{version} = $2 if defined $2;
    }
    else {
        warn "No PN found in \'$entry\'";
        return;
    }
    $result->{version} = '*' unless exists $result->{version};
    $result->{package} = $result->{cat} . '/' . $result->{pn};
    return $result;
}

# explain_version( $parsed_entry, $explain_opts )
#
sub explain_version {
    my ($record, $explain_opts ) = @_;
    my $suffix = $explain_opts->{show_orig} ? " (orig: $record->{orig})" : "";
    return colored( ['bright_red'], "BLOCKED BY USE=$record->{use}${suffix}" )
      if $record->{use} and $record->{is_block};
    return "REQUIRED BY USE=$record->{use}${suffix}" if $record->{use};
    return colored( ['bright_red'], "BLOCKS${suffix}", ) if $record->{is_block};
    return "REQUIRES${suffix}";
}

# Explain ( $hash_of_deps, $explain_opts )
sub explain {
    my ( $results, $explain_opts ) = @_;
    my $details = {};
    for my $result ( @{$results} ) {
        push @{ $details->{ $result->{phase} }->{ $result->{version} } },
          {
            orig => $result->{orig},
            exists $result->{is_block}
            ? ( 'is_block' => $result->{is_block} )
            : (),
            exists $result->{use} ? ( 'use' => $result->{use} ) : (),
          };
    }
    my @lines;

    my $INDENT_1 = " - ";
    my $INDENT_2 = "    ";
    my $INDENT_3 = colored( ['green'], "    * " );
    for my $phase ( sort keys %{$details} ) {
        push @lines, "${INDENT_1}$phase:\n";
        for my $version ( sort keys %{ $details->{$phase} } ) {
            if ( 1 == @{ $details->{$phase}->{$version} }
                and not $explain_opts->{verbose} )
            {
                push @lines,
                    "${INDENT_2}$version: "
                  . explain_version( $details->{$phase}->{$version}->[0] , $explain_opts )
                  . "\n";
            }
            else {

                push @lines, "${INDENT_2}$version:\n";

                for my $record ( @{ $details->{$phase}->{$version} } ) {
                    push @lines, $INDENT_3 . explain_version($record, $explain_opts ) . "\n";
                }
            }
        }
    }
    return @lines;
}

##
## Query functions used by get_dependencies
sub ddeps {
    my ($package) = @_;
    my $result =
      $ua->get("https://qa-reports.gentoo.org/output/genrdeps/dindex/$package");
    if ( not $result->{success} ) {

        warn "ddeps $package Failed! $result->{status} $result->{reason}" if $opts->{http_warnings};
        return;
    }
    return split /\n/, $result->{content};
}

sub rdeps {
    my ($package) = @_;
    my $result =
      $ua->get("https://qa-reports.gentoo.org/output/genrdeps/rindex/$package");
    if ( not $result->{success} ) {

        warn "rdeps $package Failed! $result->{status} $result->{reason}" if $opts->{http_warnings};
        return;
    }
    return split /\n/, $result->{content};
}

sub pdeps {
    my ($package) = @_;
    my $result =
      $ua->get("https://qa-reports.gentoo.org/output/genrdeps/pindex/$package");
    if ( not $result->{success} ) {

        warn "pdeps $package Failed! $result->{status} $result->{reason}" if $opts->{http_warnings};
        return;
    }
    return split /\n/, $result->{content};
}