- #!/usr/bin/perl
- use v5.14;
- use utf8;
- use warnings;
- no warnings 'experimental::smartmatch';
- use open qw( :std :encoding(UTF-8) );
- use Getopt::Long 2.24 qw(:config gnu_getopt);
- use IO::Interactive qw(is_interactive);
- my $USE_COLOR;
- BEGIN {
- $USE_COLOR = !(
- exists $ENV{NO_COLOR}
- or ( $ENV{COLOR} and !$ENV{COLOR} )
- or !is_interactive
- );
- $Pod::Usage::Formatter = 'Pod::Text::Color' if $USE_COLOR;
- }
- use Pod::Usage;
- my $COPYRIGHT;
- use Pod::Constants
- -trim => 1,
- 'COPYRIGHT AND LICENSE' =>
- sub { ($COPYRIGHT) = s/C<< (.*) >>/$1/gr; $COPYRIGHT =~ s/©/©/g };
- use List::Util qw(max);
- use Readonly::Tiny;
- 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
- # TODO: handle custom basepath (with builtin as default), taken as argument
- # TODO: handle multiple basepaths
- # TODO: check scripts (not only documentation)
- Log::Any::Adapter->set( 'Screen', use_color => $USE_COLOR );
- =head1 NAME
- feature-check - examine maturity and availability status of Redpill features
- =head1 VERSION
- Version v0.1.0
- =cut
- our $VERSION = 'v0.1.0';
- my $progname = path($0)->basename;
- our %OPT = ();
- my @OPT = ();
- =head1 SYNOPSIS
- feature-check [ --help | --version ]
- feature-check [OPTION...]
- feature-check --format graphviz | fdp -Tx11
- =head1 DESCRIPTION
- B<feature-check> is a command-line tool
- to parse and examine a set of Redpill features,
- and print a summary on standard output.
- Usability of each feature is evaluated
- based on coverage and embedded annotations of its documentation.
- =head1 OPTIONS
- =head2 Rendering
- =over 16
- =item B<--format>
- Output format, either of I<table> I<ascii> I<ansi> I<svg> I<inkscape> I<graphviz>
- S<(default value: I<ansi>)>
- =back
- =cut
- push @OPT, qw(
- format=s
- );
- $OPT{'format'} = 'ansi';
- =head2 General
- =over 16
- =item B<-h>, B<--help>
- print help message and exit
- =item B<--man>
- print manual and exit
- =item B<-v>, B<--version>
- print version and copyright information and exit
- =back
- =cut
- push @OPT, qw(
- verbose
- help|h
- man
- version|v
- );
- GetOptions( \%OPT, @OPT ) or pod2usage(2);
- pod2usage(1) if ( $OPT{help} );
- pod2usage(-exitval => 0, -verbose => 2) if ($OPT{man});
- if ( $OPT{version} ) { version(); exit 0; }
- pod2usage( join "\n", map {"Unknown argument: $_"} @ARGV )
- if @ARGV;
- my $BASEDIR = path('../..');
- my @TARGET = qw(executive user expert);
- readonly \@TARGET;
- my @MATURITY = qw(unusable buggy incomplete usable good);
- readonly \@MATURITY;
- use enum qw(
- UNUSABLE=0 BUGGY INCOMPLETE USABLE GOOD
- EXECUTIVE=0 USER EXPERT
- );
- my %DOCFILE = (
- ADMIN => EXPERT,
- INTRO => USER,
- OVERVIEW => EXECUTIVE,
- README => EXECUTIVE,
- SETUP => EXPERT,
- USE => USER,
- );
- readonly \%DOCFILE;
- my $threshold = USABLE;
- $log->info("acceptance threshold: $MATURITY[$threshold]");
- my $graph = Graph::Easy::Parser->from_text('graph { flow: east; }');
- $graph->catch_messages(1);
- my $root = 'features';
- my $featureref = path("$BASEDIR")->visit( \&feature );
- #use DDP; p $featureref if $log->is_debug;
- 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', $feature );
- }
- else {
- ( undef, $node{$feature} ) = $graph->add_edge( $node{$root}, $feature );
- }
- }
- my $table = Term::Table->new(
- header => [ 'feature', @TARGET ],
- rows => \@row,
- );
- for ( $OPT{format} ) {
- when ('table') { map { say $_ } $table->render }
- when ('ascii') { print $graph->as_ascii() }
- when ('ansi') { print $graph->as_boxart() }
- when ('svg') { print $graph->as_svg() }
- when ('graphviz') { print $graph->as_graphviz() }
- when ('inkscape') {
- $_ = $graph->as_svg();
- # define Inkscape namespace, for declaring "connectors"
- s{<svg\s[^>]*\K}{ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"};
- # collect identifiers for nodes
- my %node;
- $node{$2} = $1 while m{<g\s+id="(\d+)"\s+class="node">\s*<!--\s*(\S+),\s+rect\s+-->}g;
- # replace concrete arrows with abstract "connectors"
- s{
- class="edge">\s*
- <!--\s+
- from\s+(?<from>\S+)\s+
- to\s+(?<to>\S+)\s+
- -->(?<space>\s*)
- # drop these
- \K
- (?:
- \s*<!--\s*[^>]*\s*-->
- (?:
- \s*<line\s[^>]*>
- |
- \s*<g\s+[^>]*>
- \s*<line\s[^>]*>
- \s*<line\s[^>]*>
- \s*</g>
- )
- )+
- \s*<use\s[^>]*>
- }{ inkscape_path( \%+, \%node ) }gsxe;
- # keep edges away from nodes
- s{<g\s+id="(\d+)"\s+class="node"\K}{ inkscape:connector-avoid="true"}g;
- # fix styling of edges
- s/\.edge\s*{\s*font-size:\s*13px;(\s*)stroke:(\s*)black;\K/$1fill:$2none;/;
- print $_;
- }
- default { $log->fatal("unsupported format:$_") && exit 1 }
- }
- $log->error($_) for $graph->errors();
- $log->warn($_) for $graph->warnings();
- sub inkscape_path {
- my ( $mref, $nref ) = @_;
- return join $mref->{space},
- "<path d=\"\" inkscape:connector-type=\"polyline\"",
- " inkscape:connector-curvature=\"0\"",
- " inkscape:connection-start=\"#$nref->{$mref->{from}}\"",
- " inkscape:connection-end=\"#$nref->{$mref->{to}}\" />"
- }
- sub feature {
- my ($path, $state) = @_;
- my ( $feature, $docs, $maturity );
- return unless $path->is_dir;
- return if $path->basename =~ qr/\.$/;
- $feature = $path->basename;
- $log->trace("found feature: $feature");
- $docs = $path->visit( \&docfile );
- for my $target (EXECUTIVE..EXPERT) {
- my $maturity;
- if ( exists $docs->{$target} ) {
- $state->{$feature}{target}[$target]{docs} = $docs->{$target};
- $maturity = max map { $_->{maturity} } values %{ $docs->{$target} };
- }
- else {
- $maturity = UNUSABLE;
- }
- $state->{$feature}{target}[$target]{maturity} = $maturity;
- $log->debug("resolved feature $feature target $target maturity: $maturity");
- }
- if ( exists $state->{$feature}{target}[EXECUTIVE]{docs} && exists $state->{$feature}{target}[EXECUTIVE]{docs}{README} ) {
- $maturity = $state->{$feature}{target}[EXECUTIVE]{maturity};
- }
- elsif ( INCOMPLETE < $state->{$feature}{target}[EXECUTIVE]{maturity} ) {
- $maturity = INCOMPLETE;
- }
- else {
- $maturity = $state->{$feature}{target}[EXECUTIVE]{maturity};
- }
- $state->{$feature}{maturity} = $maturity;
- $log->warningf('skipping %s feature: %s', $MATURITY[$maturity], $feature)
- if $maturity < $threshold;
- }
- sub docfile {
- my ($path, $state) = @_;
- my ( $doc, $category, $content, $maturity );
- return unless $path->is_file;
- $doc = $path->basename('.md');
- return if $path->basename eq $doc;
- return unless exists $DOCFILE{$doc};
- $category = $DOCFILE{$doc}
- // return;
- $content = $path->slurp_utf8;
- if ( $content =~ qr/\bFIXME\b/ ) {
- $maturity = BUGGY;
- }
- elsif ( $content =~ qr/\bTODO\b/ ) {
- $maturity = INCOMPLETE;
- }
- else {
- $maturity //= USABLE;
- }
- $state->{$category}{$doc}{maturity} = $maturity;
- $log->trace("found docfile: $doc", { maturity => $maturity });
- }
- =head1 MATURITY
- =head2 Documentation file
- A documentation file is considered broken
- if it contains any B<FIXME> annotations,
- or otherwise considered unfinished
- if it contains any B<TODO> annotations.
- =head2 Targeted documentation
- A targeted documentation,
- for each of the Redpill targets B<executive>, B<user> and B<expert>,
- is as mature as the most mature of their files,
- or unusable if none exist for the target.
- =head2 Feature
- A feature is as mature as the most mature targeted documentation,
- except it is at most unfinished
- unless documentation complies with standard-readme specification.
- =head1 ENVIRONMENT
- =over 6
- =item NO_COLOR
- If defined, will disable color.
- Consulted before COLOR.
- =item COLOR
- Can be set to 0 to explicitly disable colors.
- The default is to use color when connected to a terminal.
- =item LOG_LEVEL
- =item QUIET
- =item VERBOSE
- =item DEBUG
- =item TRACE
- Used to emit varying details about discoveries to STDERR.
- See L<Log::Any::Adapter::Screen> for more details.
- =item LOG_PREFIX
- The default formatter groks these variables.
- See B<formatter> in L<Log::Any::Adapter::Screen> for more details.
- =back
- =encoding UTF-8
- =head1 AUTHOR
- Jonas Smedegaard C<< <dr@jones.dk> >>
- =head1 COPYRIGHT AND LICENSE
- Copyright 2021-2022 Jonas Smedegaard
- This program is free software:
- you can redistribute it and/or modify it
- under the terms of the GNU Affero General Public License
- as published by the Free Software Foundation,
- either version 3, or (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY;
- without even the implied warranty
- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- See the GNU Affero General Public License for more details.
- You should have received a copy
- of the GNU Affero General Public License along with this program.
- If not, see <https://www.gnu.org/licenses/>.
- =cut
- 1;
|