#!/usr/bin/perl
use strict;
use warnings;

use Getopt::Long;
use Make;

my (%opt, $redundancy);
if (!GetOptions(
    ## no critic (BuiltinFunctions::RequireBlockMap)
    (map +("$_!" => \$opt{$_}), qw(D g n p)),
    (map +("$_=s" => \$opt{$_}), qw(f C)),
    (map +("$_=i" => \$opt{$_}), qw(j)),
    ## use critic
    'analyse-redundancy!' => \$redundancy,
)) {
    require Pod::Usage;
    Pod::Usage::pod2usage(1);
}

chdir $opt{C} if $opt{C};

my $info = Make->new(
    GNU      => $opt{g},
    Vars     => { MAKE => "$^X $0" },
    Jobs     => $opt{j},
);
$info->parse($opt{f});

if ( $opt{D} ) {
    require Data::Dumper;
    print Data::Dumper::DumperX($info);
}
elsif ( $opt{p} ) {
    $info->Print(@ARGV);
}
elsif ( $opt{n} ) {
    print $info->Script(@ARGV);
}
elsif ( $redundancy ) {
    my $g = $info->as_graph(no_rules => 1);
    my $tcg = $g->transitive_closure(path_count => 1);
    ## no critic (BuiltinFunctions::RequireBlockGrep BuiltinFunctions::RequireBlockMap)
    my @r = grep $tcg->path_length(@$_) > 1, $g->edges;
    if (!@r) {
        print "No redundant rules found\n";
        exit 0;
    }
    @r = sort { $a->[0] cmp $b->[0] or $a->[1] cmp $b->[1] } @r;
    my %seen = map +("@$_" => 1), @r;
    for my $e (@r) {
        print "Redundant direct dep: @$e\n";
        my @direct_recipes = make_recipe_tuples($g, $e);
        my %seen_recipe;
        if (map @{ $_->[1] }, @direct_recipes) {
            $seen_recipe{$_->[0]}++ for @direct_recipes;
            print print_recipe_tuple($_, 2) for @direct_recipes;
        }
        for my $l (sort {"@$a" cmp "@$b"} grep !$seen{"@$_"}++, $tcg->all_paths(@$e)) {
            print "    @$l\n";
            my @link_recipes = make_recipe_tuples($g, [ @$l[0,1] ]);
            next if !map @{ $_->[1] }, @link_recipes;
            for my $lr (@link_recipes) {
                if ($seen_recipe{$lr->[0]}++) {
                    print "      (already seen $lr->[0])\n";
                } else {
                    print print_recipe_tuple($_, 6) for @link_recipes;
                }
            }
        }
    }
    ## use critic
}
else {
    $info->Make(@ARGV);
}

sub make_recipe_tuples {
    my ($g, $e) = @_;
    ## no critic (BuiltinFunctions::RequireBlockGrep BuiltinFunctions::RequireBlockMap)
    return map [
        "$e->[0]:$_", $g->get_edge_attribute_by_id(@$e, $_, 'recipe_raw')
    ], $g->get_multiedge_ids(@$e);
    ## use critic
}

sub print_recipe_tuple {
    my ($t, $indent) = @_;
    ## no critic (BuiltinFunctions::RequireBlockGrep BuiltinFunctions::RequireBlockMap)
    return join '', map "$_\n",
        (" " x $indent)."Recipe $t->[0]:",
        map { my $t = $_; $t =~ s/^/\t/gm; $t } @{ $t->[1] },
        ;
    ## use critic
}

=head1 NAME

pure-perl-make - a perl 'make' replacement

=head1 SYNOPSIS

  pure-perl-make [-D] [-n] [-p] [-g] [-f Makefile] [-C directory]
    [--analyse-redundancy]
    [targets] [vars]

=head1 DESCRIPTION

Performs the same function as make(1) but is written entirely in perl.
A subset of GNU make extensions is supported.
For details see L<Make> for the underlying perl module.

=head1 FLAGS

=head2 -D

Don't build, just L<Data::Dumper/DumperX> the L<Make> object.

=head2 -n

Don't build, just print what building would have done.

=head2 -p

Don't build, just print the expanded makefile.

=head2 -g

Turn on L<Make/GNU>.

=head2 --analyse-redundancy

See if there are direct dependencies that are redundant with indirect
dependencies. E.g.:

    all: L1 L2 # no need to specify L2
    L1: L2

=head1 BUGS

=over

=item *

No B<-k> flag

=back

=head1 SEE ALSO

L<Make>, make(1), L<Graph>

=head1 AUTHOR

Nick Ing-Simmons

=cut