diff options
Diffstat (limited to 'bin')
| -rwxr-xr-x | bin/feature-check.pl | 32 |
1 files changed, 31 insertions, 1 deletions
diff --git a/bin/feature-check.pl b/bin/feature-check.pl index bc3d8c4..154bb2a 100755 --- a/bin/feature-check.pl +++ b/bin/feature-check.pl @@ -3,6 +3,7 @@ use v5.14; use utf8; use warnings; +use open qw( :std :encoding(UTF-8) ); use Getopt::Long 2.24 qw(:config gnu_getopt); use IO::Interactive qw(is_interactive); @@ -30,6 +31,8 @@ use Path::Tiny; use Log::Any qw($log); use Log::Any::Adapter; use Term::Table; +use Graph::Easy; +use Graph::Easy::Parser; # TODO: handle options --quiet/--verbose/--debug # TODO: handle output scope, with options --threshold/--all @@ -135,16 +138,41 @@ readonly \%DOCFILE; my $threshold = USABLE; $log->info("acceptance threshold: $MATURITY[$threshold]"); +my $graph = Graph::Easy::Parser->from_text('graph { flow: east; }'); +my $root = 'redpill'; + my $featureref = path("$BASEDIR")->visit( \&feature ); #use DDP; p $featureref if $log->is_debug; -my @row; +my ( @row, %node ); + +$node{$root} = $graph->add_node($root); + for my $feature ( sort keys %$featureref ) { my @target = @{ $featureref->{$feature}{target} }; + next unless $featureref->{$feature}{maturity} >= $threshold; + push @row, [ $feature, map { join ', ', sort keys %{ $target[$_]{docs} } if $target[$_]{maturity} >= $threshold } EXECUTIVE..EXPERT ] if $featureref->{$feature}{maturity} >= $threshold; + + next if defined $node{$feature}; + + $node{$feature} = undef; +} + +for my $feature ( sort keys %node ) { + + next if defined $node{$feature}; + + if ( $feature =~ /^([^-]+).*\K-(?=[^-]+$)/ and defined $node{$`} and !defined $node{$feature} ) { + ( undef, $node{$feature} ) = $graph->add_edge( $node{$`}, $feature ); + $node{$feature}->set_attribute( 'label', $' ); + } + else { + ( undef, $node{$feature} ) = $graph->add_edge( $node{$root}, $feature ); + } } my $table = Term::Table->new( @@ -154,6 +182,8 @@ my $table = Term::Table->new( say $_ for $table->render; +print $graph->as_boxart(); + sub feature { my ($path, $state) = @_; my ( $feature, $docs, $maturity ); |